Microsoft Access 掲示板

データと一緒に、フィールド名を格納することはできなかった

データを整理して一括で貼り付けないと

• そもそもそのプロシージャはどのファイルのどのモジュールに記述されているのか（ Access データベースファイル上の標準モジュール、Excelマクロ有効ブックの標準モジュールなど）。

• 取得したレコードセット（の各フィールドの名前と値）をどこに、どのような形で貼り付けようとしているのか。

以上の前提についてのご説明がない限り、何を問題視されているのか不明瞭なままです。

例えば「ある accdb ファイル上に存在するテーブルから[sptx]、[sbj]、[pymt]、[fwd]、[dat]の 5 つのフィールドを選択し、全てのレコードを[id]の昇順に並べ替えた結果を取得して、新規ブック上のワークシートに複写するプロシージャを Excel マクロ有効ブック上の標準モジュールに作成しようとしている」といった場合であれば、2次元配列に拘らずとも、Excel.Range オブジェクトの CopyFromRecordset メソッドを使用する、といった方法もあるでしょう。

'ファイルパスとテーブル名は適宜書き換えること
Sub Test1()

    Dim strDatabasePath As String
    
    strDatabasePath = "C:\FolderName\FileName.accdb"
    
    If Dir(strDatabasePath) = "" Then
        MsgBox "Access データベースファイル'" & strDatabasePath & "'が見つかりません。", _
               vbExclamation, _
               "ファイル参照エラー"
        Exit Sub
    End If
    
    Dim adoCn As ADODB.Connection
    Dim strConnectString As String
    
    Set adoCn = New ADODB.Connection
    
    With adoCn
        .CursorLocation = adUseClient
        .CommandTimeout = 60
        strConnectString = "Provider=Microsoft.ACE.OLEDB.12.0;Mode=Read;" & _
                           "Data Source=" & strDatabasePath
        Debug.Print strConnectString
        .ConnectionString = strConnectString
        .Open
    End With
    
    Dim adoRs As ADODB.Recordset
    Dim strSQL As String
    
    Set adoRs = New ADODB.Recordset
       
    With adoRs
        Set .ActiveConnection = adoCn
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        strSQL = "SELECT t1.[sptx], t1.[sbj], t1.[pymt], t1.[fwd], t1.[dat]" & _
                 " FROM [テーブル名] t1" & _
                 " ORDER BY t1.[id];"
        Debug.Print strSQL
        .Source = strSQL
        .Open
    End With
    
    Dim adoFld As ADODB.Field
    Dim wbkDestination As Excel.Workbook
    Dim wsDestination As Excel.Worksheet
    Dim lngColumn As Long
    
    Set wbkDestination = Workbooks.Add
    Set wsDestination = wbkDestination.Worksheets(1)
    
    wsDestination.Cells(1, 1).Resize(1, adoRs.Fields.Count).NumberFormat = "@"
    For lngColumn = 1 To adoRs.Fields.Count
        Set adoFld = adoRs.Fields(lngColumn - 1)
        wsDestination.Cells(1, lngColumn).Value = adoFld.Name
        Set adoFld = Nothing
    Next
    
    wsDestination.Cells(2, 1).CopyFromRecordset adoRs
    wsDestination.UsedRange.EntireColumn.AutoFit
    
    adoRs.Close
    Set adoRs = Nothing
    adoCn.Close
    Set adoCn = Nothing
    
    Set wsDestination = Nothing
    Set wbkDestination = Nothing

End Sub