根据许多条件将数据从Access导出到Excel工作簿/工作表
我有一些数据结构如下：
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 等等…有六万行数据。
我正在寻找将数据从Access表移动到许多不同的工作簿，基于intRouterLocation名称。 我挣扎的一点是，在每个单独的工作簿中，还要将数据移动到名为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
我想我build立了你需要的东西。 只要把它指向正确的表，字段和出口位置，如在testing子。 它需要从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