Access

【ACCESS VBA】Excelファイルを取り込んで必要な項目のみに整形したExcelファイルを出力する

今回は『ベースとなるExcelファイル(列項目可変)を加工して必要なフィールドだけに整形して新しいExcelファイルを作成する方法』をご紹介します。

なんでもAccessでする必要があるか?と言われそうですが…(;^_^A

背景としてはQlikSenseでエクスポートしたデータファイルを顧客毎に加工して出力するのが面倒だという課題がありました。

顧客によって出力する項目も様々だし、QlikSenseからダウンロードしたデータの項目も可変…。

何もかも可変なので変換ツールを作ってしまおう!というものです。

手順の概要

大まかな処理の手順は以下の通りです。

  1. 元となるExcelファイルをインポート
  2. インポートしたテーブルから各フィールド名をワークテーブルに格納
  3. 利用者にはワークテーブルのフィールド名リストに出力ON/OFFを指定させる
  4. 出力フラグが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のインポートって、インポート元データの最初の8行位でその項目の型を判断するのです。

このため本来文字列でたまたま先頭8行が数字だった項目などがインポートエラーになってしまいました。

全て文字列で取り込めば問題ないのですが可変なので事前にテーブルを作成しておくわけにもいかず…。

結局元のExcelファイルの2行目(ヘッダー行の下)に全列ダミー文字列を挿入するという姑息なことをしました…。

インポートしたテーブルから各フィールド名をワークテーブルに格納

①フィールド名を格納するテーブルを事前に用意しておきます。

【TMPフィールド名リスト】テーブル

フィールド名 データ型 備考
ID 数値型 出力順がずれないようフィールドの順番をセット
フィールド名 テキスト型 インポートテーブルのフィールド名を格納
サンプルデータ テキスト型 1行目の生データをサンプルとして格納
出力フラグ Yes/No型 Outputファイルに必要な項目を指定するフラグ

②インポートしたテーブルの全フィールドのフィールド名を取得して【TMPフィールド名リスト】に格納。

ついでに、サンプルデータとして1行目のデータをセットする。

'------------------------------------------------------------
'   処理内容:フィールド名取得
'   引数:元テーブル名,格納先テーブル名
'   戻り値: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
    
    'フィールドが1つも指定されていなかったらエラー
    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
アズビーパートナーズ
プログラマーと社内SEとしての経験を活かして、 情報システム部門のご相談を承ります。 得意な分野はAccessによる短納期開発、 BIツール(QlikSense/QlikView)の開発です。 現在はCMSを利用したホームページの作成にも力を入れています。
今のスキルのままで大丈夫?

あなたのスキル。今のままで大丈夫ですか?

時代のニーズに合った開発スキルを身につけてあなたの価値を高めましょう。

\オンラインでも教室でも学べるおすすめのスクール/

TECH::CAMP(エンジニアスクール)

まずは基礎から・・・という方はProgateUdemyどっとインストールなどがおすすめ!

スキルアップについて詳しくはこちら