根据多种条件将数据从 Access 导出到 Excel 工作簿/工作表

Question

我有一些数据结构如下：

sglAccNumber    intDaysOld      intRouterLocation   intDaysInLocation
1638828663      614             Customer Service    05. - 61-90 Days
1955963013      348             Advertising         03. 16-45 Days
1198680816      1678            Accounting          09. 401-730 Days
1892708307      1860            Accounting          010. 730+ Days
1785581943      1005            Asset Management    02. 6-15 Days
1942406908      1853            Finances            09. 401-730 Days

等等...有60,000行数据。

我希望根据 intRouterLocation 名称将数据从 Access 表移动到许多不同的工作簿。我正在努力解决的问题是，在每个单独的工作簿中，还要将数据移动到名为 intDaysInLocation 的工作表中。

例如，使用上述数据，会计工作簿将生成两张工作表，一张用于 09。 401-730 天，一个用于 010。 730+ 天 并且适当的条目将填充每个。

过去几天我一直在为此苦苦挣扎，可以将数据按名称或按值进入工作簿或 intDaysInLocation，但将它们结合起来会更好我。

这是使用 VBA 可以实现的吗？

我用来整理工作表的代码（全部在一张工作表中，不考虑 intRouterLocation）：

Sub exportMk2 ()

Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim rs As DAO.Recordset
Dim strPath As String
Dim strSelectOneType As String
Dim strSelectDaysInLocation As String

' (change strPath back to what you need)
strPath = CurrentProject.Path & Chr(92) & "Pets_dataset_export_" & _
    Format(Date, "yyyy-mm-dd") & ".xlsx"
strSelectDaysInLocation = "SELECT DISTINCT p.intDaysInLocation" & vbCrLf & _
    "FROM Worksheet AS p;"

Set db = CurrentDb
Set rs = db.OpenRecordset(strSelectDaysInLocation, dbOpenSnapshot)
Set rsRouters = db.OpenRecordset(strSelectDaysInLocation, dbOpenSnapshot)

For Each routerLocation In rsRouters
    Do While Not rs.EOF
        strSelectOneType = "SELECT p.ID, p.intDaysInLocation, p.intRouterLocation" & vbCrLf & _
            "FROM Worksheet AS p" & vbCrLf & _
            "WHERE p.intDaysInLocation='" & rs!intDaysInLocation.Value & "';"
        Debug.Print strSelectOneType
        Set qdf = db.QueryDefs("qryExportMe")
        qdf.SQL = strSelectOneType
        qdf.Close
        DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, _
            "qryExportMe", strPath, True, "woot " & rs!intDaysInLocation.Value
        rs.MoveNext
    Loop
Next
rs.Close
End Sub

Answer 1

我想我构建了你需要的东西。只需将其指向正确的表、字段和导出位置，就像在测试子中一样。它需要从 Access 运行，并引用您的 Excel 库。

Public Sub Test()

    ExportToExcel "tblData", "intRouterLocation", "intDaysInLocation", CurrentProject.Path & "\Export\"

End Sub

Public Sub ExportToExcel(sTableName As String, sWorkBookNameField As String, sSheetNameField As String, sDestinationFolder As String)

    Dim rsData          As Recordset
    Dim oXL             As Excel.Application
    Dim oWB             As Excel.Workbook
    Dim oSH             As Excel.Worksheet
    Dim sPrevWB         As String
    Dim sPrevSheet      As String
    Dim lRecordcount    As String
    Dim vTempArray()    As Variant
    Dim lFieldID        As Long
    Dim lRecordID       As Long

    With CurrentDb.OpenRecordset("SELECT [" & sWorkBookNameField & "],[" & sSheetNameField & "] FROM [" & sTableName & "] GROUP BY [" & sWorkBookNameField & "],[" & sSheetNameField & "] ORDER BY [" & sWorkBookNameField & "],[" & sSheetNameField & "] DESC;")
        If .EOF And .BOF Then
            .Close
            MsgBox "No data found"
            Exit Sub
        End If

        Set oXL = New Excel.Application

        Do Until .EOF
            If sPrevWB <> .Fields(sWorkBookNameField) Then
                If Not oWB Is Nothing Then
                    oWB.Close True
                    Set oWB = oXL.Workbooks.Add
                Else
                    With oXL
                        Set oWB = .Workbooks.Add
                        .Calculation = xlCalculationManual
                        .ScreenUpdating = False
                    End With
                End If

                oWB.SaveAs sDestinationFolder & .Fields(sWorkBookNameField) & ".xlsx"
                sPrevWB = .Fields(sWorkBookNameField)
                Set oSH = oWB.Sheets(1)
            ElseIf sPrevSheet <> .Fields(sSheetNameField) Then
                If oSH.Index + 1 > oWB.Sheets.Count Then oWB.Sheets.Add
                Set oSH = oWB.Sheets(oSH.Index + 1)
            End If

            oSH.Name = .Fields(sSheetNameField)

            'Push data to sheet (numerous methods, I just picked one)
            Set rsData = CurrentDb.OpenRecordset("SELECT * FROM [" & sTableName & "] WHERE [" & sWorkBookNameField & "]='" & .Fields(sWorkBookNameField) & "' AND [" & sSheetNameField & "]='" & .Fields(sSheetNameField) & "'")

            rsData.MoveLast
            lRecordcount = rsData.RecordCount
            rsData.MoveFirst

            vTempArray = rsData.GetRows(lRecordcount)

            For lFieldID = 0 To UBound(vTempArray, 1)
                oSH.Cells(1, lFieldID + 1) = rsData.Fields(lFieldID).Name
                For lRecordID = 0 To UBound(vTempArray, 2)
                    oSH.Cells(lRecordID + 2, lFieldID + 1) = vTempArray(lFieldID, lRecordID)
                Next lRecordID
            Next lFieldID
            oSH.Cells.EntireColumn.AutoFit
            .MoveNext
        Loop
        .Close
    End With

    oWB.Save
    oXL.Quit

    Set rsData = Nothing
    Set oSH = Nothing
    Set oWB = Nothing
    Set oXL = Nothing

End Sub