Question

我编写了一段VBA代码，它遍历访问数据库查询列表并将它们复制到一个excel工作簿中。代码工作正常，但我无法弄清楚如何在复制到excel工作簿时将标题包含到数据中。

Sub AccessQuerie()

    Dim A As Object
    Application.DisplayAlerts = False
    Set A = CreateObject("Access.Application")

    Dim wkb As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim sheetNum As Integer
    Dim queryList

    Set wkb = Excel.Workbooks("macro.xlsm")

    A.Visible = False
    A.OpenCurrentDatabase ("C:\accessdb") 'Access database file path

    queryList = wkb.Sheets("settings").Range("K28:K43").Value

    sheetNum = 3

    For Each Item In queryList
        A.DoCmd.OpenQuery (Item)
        Application.DisplayAlerts = True

        Set ws = ThisWorkbook.Sheets(sheetNum)

        Dim rs As Object
        Set rs = A.CurrentDb().QueryDefs(Item).OpenRecordset()

        ws.Range("A1").Value = Item

        If Not rs.EOF Then
            ws.Range("A2").CopyFromRecordset rs
        End If

        rs.Close

        sheetNum = sheetNum + 1
    Next

End Sub

我的输出数据如下所示

10  10  10  10  10
10  10  10  10  10
10  10  10  10  10

但我希望得到这个输出

NumData NumData NumData NumData NumData
10  10  10  10  10
10  10  10  10  10
10  10  10  10  10

感谢您的帮助：）

Answer 1

您必须在单独的代码段中添加字段名称。

Dim field
Dim lCol As Long

lCol = 0
For Each field In rs.Fields
    ws.Range("A2").Offset(, lCol) = field.Name
    lCol = lCol + 1
Next field

并且不要忘记将其余数据向下移动一行：

If Not rs.EOF Then
    ws.Range("A3").CopyFromRecordset rs
End If

Answer 2

您可以像这样

遍历查询中的字段

Dim qtQueryDefs As QueryDef
Dim rsRs As Recordset
Dim fField As Field

For Each qtQueryDefs In CurrentDb.QueryDefs
    Set rsRs = qtQueryDefs.OpenRecordset()
    For Each fField In rsRs.Fields
        Debug.Print fField.Name
    Next
Next

获取来自访问数据库

2 个答案: