今回は『ベースとなるExcelファイル（列項目可変）を加工して必要なフィールドだけに整形して新しいExcelファイルを作成する方法』をご紹介します。
なんでもAccessでする必要があるか？と言われそうですが…(;^_^A
背景としてはQlikSenseでエクスポートしたデータファイルを顧客毎に加工して出力するのが面倒だという課題がありました。
顧客によって出力する項目も様々だし、QlikSenseからダウンロードしたデータの項目も可変…。
何もかも可変なので変換ツールを作ってしまおう！というものです。
手順の概要
大まかな処理の手順は以下の通りです。
- 元となるExcelファイルをインポート
- インポートしたテーブルから各フィールド名をワークテーブルに格納
- 利用者にはワークテーブルのフィールド名リストに出力ON/OFFを指定させる
- 出力フラグがONのフィールドだけを取得するSQLを作成しレコードセットをEXCEL出力
各手順の解説
元となるExcelファイルをインポート
インポートする元ファイルの項目数や項目名は可変であるという前提なのでインポート先のテーブルは毎回新しく作成する作りにします。
よって、指定のインポート先テーブルが存在した場合は削除するというロジックを入れておきます。
'既にﾃｰﾌﾞﾙが存在したら削除
If IsTable("TMPデータ") = True Then
DoCmd.DeleteObject acTable, "TMPデータ"
End If
'ｲﾝﾎﾟｰﾄ
DoCmd.TransferSpreadsheet , acSpreadsheetTypeExcel12, "TMPデータ", strTmpFileName, True, "Sheet1!"
▼IsTabel()関数は以下の記事を参考に▼
VBAでテーブルの存在チェックをする関数一時テーブル作成前、インポート前などあらかじめこれから作成する予定のテーブルが存在するかどうかチェックする際に使える関数です。コピペでどうぞ。...
実はこの時ちょっとした問題が発生しました。
Accessのインポートって、インポート元データの最初の８行位でその項目の型を判断するのです。
このため本来文字列でたまたま先頭８行が数字だった項目などがインポートエラーになってしまいました。
全て文字列で取り込めば問題ないのですが可変なので事前にテーブルを作成しておくわけにもいかず…。
結局元のExcelファイルの２行目（ヘッダー行の下）に全列ダミー文字列を挿入するという姑息なことをしました…。
インポートしたテーブルから各フィールド名をワークテーブルに格納
①フィールド名を格納するテーブルを事前に用意しておきます。
【TMPフィールド名リスト】テーブル
| フィールド名 | データ型 | 備考 |
| ID | 数値型 | 出力順がずれないようフィールドの順番をセット |
| フィールド名 | テキスト型 | インポートテーブルのフィールド名を格納 |
| サンプルデータ | テキスト型 | １行目の生データをサンプルとして格納 |
| 出力フラグ | Yes/No型 | Outputファイルに必要な項目を指定するフラグ |
②インポートしたテーブルの全フィールドのフィールド名を取得して【TMPフィールド名リスト】に格納。
ついでに、サンプルデータとして１行目のデータをセットする。
'------------------------------------------------------------
' 処理内容:フィールド名取得
' 引数:元テーブル名,格納先テーブル名
' 戻り値:True/False
' 更新：
'------------------------------------------------------------
Function フィールド名取得(TableName As String, ListTable As String) As Boolean
Dim strsql As String
Dim cn As ADODB.Connection
Dim DataRs As New ADODB.Recordset
Dim ListRs As New ADODB.Recordset
Dim i As Integer
Dim topFieldName As String
On Error GoTo Err_Exit
'戻り値初期化
フィールド名取得 = False
Set cn = Application.CurrentProject.Connection
DoCmd.SetWarnings False
'ﾘｽﾄﾃｰﾌﾞﾙﾚｺｰﾄﾞｾｯﾄｸﾘｱ
strsql = "DELETE * FROM " & ListTable
DoCmd.RunSQL strsql
'指定のﾃｰﾌﾞﾙのﾚｺｰﾄﾞｾｯﾄを作成
DataRs.Open TableName, cn, adOpenDynamic, adLockOptimistic
'格納先のﾘｽﾄﾃｰﾌﾞﾙﾚｺｰﾄﾞｾｯﾄを作成
ListRs.Open ListTable, cn, adOpenDynamic, adLockOptimistic
With DataRs
'事前にデータが存在していることを確認済み
'1フィールド目にDummy文字列が入っているﾚｺｰﾄﾞは削除
.Find .Fields(0).Name & "='" & csDummy & "'"
.Delete
.MoveFirst
For i = 0 To (DataRs.Fields.Count - 1)
ListRs.AddNew
'フィールド名をセット
ListRs.Fields("ID") = i + 1
ListRs.Fields("フィールド名") = .Fields(i).Name
'サンプルデータをセット
If IsNull(.Fields(i).VALUE) Then
ListRs.Fields("サンプルデータ") = ""
Else
ListRs.Fields("サンプルデータ") = .Fields(i).VALUE
End If
ListRs.Update
Next
End With
'正常終了
フィールド名取得 = True
End_Proc:
DataRs.Close: Set DataRs = Nothing
ListRs.Close: Set ListRs = Nothing
cn.Close: Set cn = Nothing
DoCmd.SetWarnings True
Exit Function
Err_Exit:
MsgBox "フィールド名取得()" & Err.Number & ":" & Err.Description, vbOKOnly + vbCritical
GoTo End_Proc
End Function
利用者にはワークテーブルのフィールド名リストに出力ON/OFFを指定させる
格納した項目を表示する画面を用意し、利用者に出力のON/OFFを指定させExcel出力します。
出力フラグがONのフィールドだけを取得するSQLを作成しレコードセットをEXCEL出力
'------------------------------------------------------------
' 処理内容:指定のフィールドをExcel出力
' 引数:なし
' 戻り値:
' 更新：
'------------------------------------------------------------
Private Sub OutputExcel()
Dim strsql As String
Dim strFileName As String
Dim xlapp As Object
Dim myCn As New ADODB.Connection
Dim myRs As New ADODB.Recordset
Dim colcnt As Integer
On Error GoTo Err_Exit
'ﾌｧｲﾙ名作成
strFileName = csOutputFileName & "_" & Format(Date, "yyyymmdd") & ".xlsx"
'出力対象のﾃﾞｰﾀを絞り込むsqlを作成
If MkOutputSql(strsql) = False Then
Exit Sub
End If
'EXCELｱﾌﾟﾘｹｰｼｮﾝを起動
Set xlapp = CreateObject("Excel.Application")
Set myCn = CurrentProject.Connection
'ﾚｺｰﾄﾞｾｯﾄｵｰﾌﾟﾝ
myRs.Open strsql, myCn, adOpenForwardOnly, adLockReadOnly
With xlapp
'ｾｯﾄする過程が見えないよう一旦不可視
.Visible = False
'新しいBookを追加
.Workbooks.Add
.Worksheets("Sheet1").Select
'ﾚｺｰﾄﾞｾｯﾄのﾌｨｰﾙﾄﾞ名（見出し）出力処理
For colcnt = 0 To myRs.Fields.Count - 1
.Worksheets("Sheet1").Cells(1, colcnt + 1).VALUE = myRs.Fields(colcnt).Name
Next
'結果値出力処理(1行目はﾍｯﾀﾞｰなので、2行目1列目からｾｯﾄ
.Cells(2, 1).CopyFromRecordset myRs
'列幅自動調整
.Cells.EntireColumn.AutoFit
'全列文字列で保存されている数値を数値に変換…(A)
colcnt = 1
While Nz(.Cells(1, colcnt)) <> ""
.Columns(colcnt).TextToColumns Comma:=True
colcnt = colcnt + 1
Wend
.Visible = True
MsgBox "出力しました。", vbOKOnly + vbInformation
End With
End_Proc:
Set myRs = Nothing: Close
Set myCn = Nothing: Close
xlapp.Quit
Exit Sub
Err_Exit:
MsgBox Err.Number & ":" & Err.Description, vbOKOnly + vbCritical, "OutputExcel()"
GoTo End_Proc
End Sub
'------------------------------------------------------------
' 処理内容:出力用のﾚｺｰﾄﾞｾｯﾄ用SQL文を作る
' 引数:なし
' 戻り値:True:OK False:NG
' 更新：
'------------------------------------------------------------
Private Function MkOutputSql(ByRef strsql) As Boolean
Dim myRs As Recordset
'戻り値初期化
MkOutputSql = False
strsql = ""
Set myRs = CurrentDb.OpenRecordset("SELECT * FROM TMPフィールド名リスト where 出力フラグ=TRUE")
With myRs
If Not .EOF Then
.MoveFirst
While Not .EOF
If strsql <> "" Then
strsql = strsql & ","
End If
'フィールド名に不正な文字を含む場合があるので大括弧囲み
strsql = strsql & "[" & .Fields("フィールド名") & "]"
.MoveNext
Wend
End If
End With
Set myRs = Nothing: Close
'フィールドが１つも指定されていなかったらエラー
If strsql <> "" Then
strsql = "SELECT " & strsql & " FROM TMP進捗データ"
MkOutputSql = True
Else
MsgBox "出力項目が選択されていません。", vbOKOnly + vbInformation
End If
Exit Function
Err_Exit:
MsgBox "MkOutputSql()" & Err.Number & ":" & Err.Description, vbOKOnly + vbCritical
End Function
このプログラムでは出力したExcelを保存するロジックを含みませんので、出力した利用者が目視確認を自分で保存する形になっています。
「全列文字列で保存されている数値を数値に変換…(A)」の処理は以下の記事を参考に…
EXCEL「数値が文字列として保存されています」を一気に数値変換する方法Excelの「数値が文字列として保存されています」警告を解消する方法を手動と自動で3通りご紹介しています。コピペOKのサンプルプログラムをExcelとAccessでご用意しています。...
まとめ
使う人がいるかどうか不明ですが、可変フィールドのデータを取得して後処理をするシチュエーションはそこそこあるかと思います。
その際の参考になれば幸いです。
ABOUT ME
