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

我认为我构建了你需要的东西。只需将其指向正确的表，字段和导出位置，如Test子中所示。它需要从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

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

1 个答案: