excel - 按记录将 Access 查询结果导出到文件中的新工作表

问题描述

我正在尝试锻炼如何将查询的唯一记录拆分为同一个 Excel 工作簿（模板文件）中的新工作表。我的访问查询具有以下字段：

项目编号、项目名称、任务编号、项目发起人、全年预算、4 月、5 月、6 月、7 月、8 月、9 月、10 月、11 月、12 月、1 月、2 月、3 月、完整、年度预测。

我希望能够为每个项目编号创建一个新的工作表并列出相关数据，并将工作表重命名为项目编号......在花费数小时处理类似请求的其他代码后，我有一个完整的思维障碍，但不能让任何事情按照我需要的方式行事？

有没有人有想法或可以指出我正确的方向，我在 vba 不是一个完全的新手，但这个让我很好，真正地卡住了。

非常感谢：）

大家好，感谢您的建议，我已经设法将代码拼凑在一起以溢出数据并导出到各个工作表并且工作正常。我现在需要将任何关联数据从另一个查询复制到相关工作表中的“表”低于其他数据，但我运气不佳。它要么将一条记录复制到其中一个工作表，要么将所有记录复制到单个工作表，而不管。谁能指出我正确的方向？

Option Compare Database

Global iter As Integer
Sub Loop_Practice2()



 Dim rs As DAO.Recordset
    Dim ProjectNumber As DAO.Recordset
    Dim i As Integer
    Dim j As Integer
    Dim Worksheet_Count As Integer
    Dim sSql As String
    Dim Project_Count As Integer
    Dim iCol As Integer
    Dim mypath As String
    Dim mvalue As String
    Dim myfile As String
    Dim mynewfile As String
    Dim mynewpath As String
    Dim wb As Excel.Workbook
    Dim WS As Excel.Worksheet
    Dim sFile As String
    mypath = Application.CurrentProject.Path & "\"
    myfile = ("PIN Export Template.xlsx")
    mynewpath = (Application.CurrentProject.Path & "\")
    mynewfile = ("PIN Export Template.xlsx - " & Format(Now(), "yyyy-mm-dd") & ".xlsx")
    sFile = mypath & myfile
'    ' Use Dir to check if file exists
    If Dir(sFile) = "" Then
' if file does not exist display message
        MsgBox "Could not find the file " & sFile & " - Please ensure it is in the same location as the database."
        Exit Sub
    End If
'Open Excel
    Excel.Application.Visible = True
    Excel.Application.Workbooks.Open (sFile)
'Define Access Query to be exported
    Set ProjectNumber = CurrentDb.OpenRecordset("SELECT DISTINCT qry_MP_PDP_PIN_Analysis_Step_01_FY_Position_Monthly.[Project Number] from qry_MP_PDP_PIN_Analysis_Step_01_FY_Position_Monthly")
    If ProjectNumber.EOF Then Exit Sub
    ProjectNumber.MoveLast
    Project_Count = ProjectNumber.RecordCount - 1
    ProjectNumber.MoveFirst
'Create individual PIN sheets from Query Dataset
    Excel.Application.Worksheets("PIN").Select
    Worksheet_Count = Excel.Application.Worksheets("PIN").Select
    Do Until Worksheet_Count = Project_Count
        Worksheets("PIN").Copy After:=Worksheets("PIN")
        If iter = 0 Then
            iter = 1
        End If
        ActiveSheet.Name = ("PIN") & iter
        iter = iter + 1
        Worksheet_Count = Worksheet_Count + 1
    Loop
    j = 1
'Add qry_MP_PDP_PIN_Analysis_Step_01_FY_Position_Monthly data
    Do Until ProjectNumber.EOF
        sSql = "SELECT *"
        sSql = sSql & " FROM qry_MP_PDP_PIN_Analysis_Step_01_FY_Position_Monthly"
        sSql = sSql & " Where qry_MP_PDP_PIN_Analysis_Step_01_FY_Position_Monthly.[Project Number]=" & ProjectNumber("[Project Number]")
        Set rs = CurrentDb.OpenRecordset(sSql, dbOpenDynaset)
        Set Pin_Sheet = ActiveWorkbook.Sheets("PIN" & j)
'Rename the PIN sheet to individual Project Number
        Pin_Sheet.Name = ProjectNumber("[Project Number]")
'Create PIN Analysis Column Headings
        For iCol = 0 To rs.Fields.Count - 1
            Pin_Sheet.Cells(13, iCol + 4).Value = rs.Fields(iCol).Name
        Next
'Populate PIN_Analysis_Step_01_FY_Position_Monthly Data
        Pin_Sheet.Cells(14, 4).CopyFromRecordset rs
        j = j + 1
        ProjectNumber.MoveNext
        Loop
    Excel.Application.ActiveWorkbook.SaveAs (mynewpath & mynewfile)
    Set Pin_Sheet = Nothing
    Set ProjectNumber = Nothing
    Set ProjectNumber2 = Nothing
    Set rs = Nothing
    Set ProjectNumber = Nothing
    Set wb = Nothing
    Set WS = Nothing
    CurrentDb.Close

ActiveWorkbook.Close
Excel.Application.Quit
End Sub

标签： excelms-accessvba

excel - 按记录将 Access 查询结果导出到文件中的新工作表

问题描述

解决方案

推荐阅读