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

'既にﾃｰﾌﾞﾙが存在したら削除
If IsTable("TMPデータ") = True Then
　　　　DoCmd.DeleteObject acTable, "TMPデータ"
End If
'ｲﾝﾎﾟｰﾄ
DoCmd.TransferSpreadsheet , acSpreadsheetTypeExcel12, "TMPデータ", strTmpFileName, True, "Sheet1!"

'------------------------------------------------------------
'   処理内容:フィールド名取得
'   引数:元テーブル名,格納先テーブル名
'   戻り値: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

'------------------------------------------------------------
'   処理内容:指定のフィールドを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