Question

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

项目编号，项目名称，任务编号，项目发起人，全年预算，4月，5月，6月，7月，8月，9月，10月，11月，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

Answer 1

AS 'Erik von Asmuth'建议将这是一个广泛的问题，分为不同的任务并共享您的代码。到现在为止您一直在尝试什么。

我只能将您指向 Daniel Pineault 撰写的一篇文章。他创建了一个名为 ExportRecordset2XLS 的函数，您可以通过该函数传递记录集，工作表名称等。

您必须为不同的项目编号创建一个循环，并将其作为参数传递给此函数。您还需要根据您的要求修改此代码以处理不同的任务。

https://www.devhut.net/2017/03/15/ms-access-vba-export-recordset-to-excel/

通过记录将Access查询结果导出到文件中的新工作表

1 个答案: