根據當前日期創建文件夾並基於過濾器保存 excel 工作簿

Question

我正在開發一個數據庫，它將一起編譯 4 個記錄集，以便將 output 3 excel 工作表放入每個工作中心或 Office 符號的單個工作簿中。 這將每周更新一次，每次更新都會生成新的工作簿。

我設法以我想要的方式創建工作簿。 但是，保存文件已成為一個問題。 這個 sub 的開頭使用今天的日期創建一個文件夾。 以下所有內容都會創建單獨的報告。 當我嘗試使用“wb.Saveas”時，問題就來了。 它不是在創建的文件夾中使用“Do While Not”中的名稱保存報告，而是使用今天的日期和“Do While Not”output 保存報告（參見附圖）。

我對 Select 查詢（AD1、PT1 和 LV1）也有問題，沒有給我一致的結果。 有時我不是只過濾 1 個 Office 符號，而是在一個 excel output 上得到 3 或 4 個。

在此先感謝您的幫助。

請原諒我在編碼方面缺乏一致性。 我在這個過程中磕磕絆絆，我不知道正確的格式禮儀。

命名格式不正確

Private Sub Export_Button_Click()
Dim sFolderName As String, sFolder As String
Dim sFolderPath As String

    sFolder = "C:\Users\1023491733A\Desktop\TEST\"
    sFolderName = Format(Now, "dd MMM yyyy")
    sFolderPath = "C:\Users\1023491733A\Desktop\TEST\" & sFolderName
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    If oFSO.FolderExists(sFolderPath) Then
    MsgBox "Folder already exists  with today's date!", vbInformation, "VBAF1"
    Else
    MkDir sFolderPath
    MsgBox "Folder has created with today's date: " & vbCrLf & vbCrLf & sFolderPath, vbInformation, "VBAF1"
    End If


Dim db As DAO.Database
Set db = CurrentDb
Dim OS As DAO.Recordset
Set OS = db.OpenRecordset("Office_Symbols")
Dim AD As DAO.Recordset
Set AD = db.OpenRecordset("XLS-Airfield")
Dim PT As DAO.Recordset
Set PT = db.OpenRecordset("XLS-Fitness")
Dim LV As DAO.Recordset
Set LV = db.OpenRecordset("XLS-Leave")

Dim xl
Set xl = CreateObject("Excel.Application")
Dim wb As Object
Set wb = xl.Workbooks.Add("C:\Users\1023491733A\Desktop\TEST\Template.xlsx")
Dim wr As Object
Set wr = wb.Worksheets("Airfield")
Dim ws As Object
Set ws = wb.Worksheets("Fitness")
Dim wt As Object
Set wt = wb.Worksheets("Leave")

        
   
Do While Not OS.EOF


    
    
    Dim AD1 As DAO.Recordset
    Set AD1 = db.OpenRecordset("SELECT [XLS-Airfield].* FROM [XLS-Airfield] WHERE ([XLS-Airfield].OFFICE_SYMBOL)='" & OS.Fields(0) & "';")
    Dim PT1 As DAO.Recordset
    Set PT1 = db.OpenRecordset("SELECT [XLS-Fitness].* FROM [XLS-Fitness] WHERE ([XLS-Fitness].OFFICE_SYMBOL) ='" & OS.Fields(0) & "';")
    Dim LV1 As DAO.Recordset
    Set LV1 = db.OpenRecordset("SELECT [XLS-Leave].* FROM [XLS-Leave] WHERE ([XLS-Leave].OFFICE_SYMBOL) ='" & OS.Fields(0) & "';")
   

    wr.Select
    wr.Range("A1").Select

    For Each fld In AD1.Fields
        xl.ActiveCell = fld.Name
        xl.ActiveCell.Offset(0, 1).Select
    Next

    AD1.MoveFirst
    
    wr.Cells(2, 1).CopyFromRecordset AD1
        
'Break

    ws.Activate
    ws.Range("A1").Select

    For Each fld In PT1.Fields
        xl.ActiveCell = fld.Name
        xl.ActiveCell.Offset(0, 1).Select
    Next
    
    PT1.MoveFirst
    
    ws.Cells(2, 1).CopyFromRecordset PT1

'Break

    wt.Activate
    wt.Range("A1").Select

    For Each fld In LV1.Fields
        xl.ActiveCell = fld.Name
        xl.ActiveCell.Offset(0, 1).Select
    Next

    LV1.MoveFirst
    
    wt.Cells(2, 1).CopyFromRecordset LV1


    







    Dim sFileName As String
    sFileName = OS.Fields(0)
    
wb.SaveAs sFolderPath & sFileName

Set AD1 = Nothing
Set PT1 = Nothing
Set LV1 = Nothing

OS.MoveNext

Loop

OS.Close
        
        wr.Rows("1:1").Font.Bold = True 'Row 1 Bold
        wr.Cells.EntireColumn.AutoFit  'Autofit all the columns
        ws.Rows("1:1").Font.Bold = True 'Row 1 Bold
        ws.Cells.EntireColumn.AutoFit  'Autofit all the columns
        wt.Rows("1:1").Font.Bold = True 'Row 1 Bold
        wt.Cells.EntireColumn.AutoFit  'Autofit all the columns

Set OS = Nothing
Set AD = Nothing
Set PT = Nothing
Set LV = Nothing

End Sub

Answer 1

我已經解決了我的問題。 我不確定這是否是最好的解決方案，但這是我所做的更改。

將對象調暗到 Do While Not 循環中，並且在 OS.MoveNext 之前將每個對象設置為空。

Do While Not OS.EOF
   
       Dim xl As Object
       Set xl = CreateObject("Excel.Application")
       Dim wb As Object
       Set wb = xl.Workbooks.Open("C:\Users\1023491733A\Desktop\TEST\Template.xlsx")
       Dim wr As Object
       Set wr = wb.Worksheets("Airfield")
       Dim ws As Object
       Set ws = wb.Worksheets("Fitness")
       Dim wt As Object
       Set wt = wb.Worksheets("Leave")

我在 sFolderName 中添加了一個反斜杠，如下所示。 由於某些我不知道的原因，使用兩個變量（“sfolderpath”和“OS.Fields（0））總是會給出運行時1004錯誤。但是在它們之間插入一個常數似乎可以解決這個問題，但我又一次不知道為什么。

    sFolderName = (Format(Now, "dd MMM yyyy") & "\")
    Dim sfilename As String
    sfilename = sFolderPath & "TEST" & OS.Fields(0)
    wb.SaveAs sfilename

我了解第一個修復，因為循環使用的是上一次迭代中的 excel 工作簿。 但我無法理解為什么 sFileName 修復有效。 如果有人能解釋這一點，我將不勝感激。