基于当前日期创建文件夹并按筛选保存Excel工作簿的问题求助

我正在开发一个数据库，用于整合4个记录集，为每个Workcenter或Office Symbol输出包含3个Excel工作表的单个工作簿，每周更新并生成新工作簿。目前已成功创建符合需求的工作簿，但遇到两个问题：

• 保存文件时，使用wb.SaveAs未能按Do While循环中的Office Symbol命名，反而文件名包含当前日期与Office Symbol；
• AD1、PT1、LV1这三个Select查询结果不一致，无法稳定筛选单个Office Symbol，偶尔会在一份Excel输出中出现3-4个Office Symbol的数据。

附上相关VBA代码：

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

问题1：文件名错误包含日期 #

原因 #

sFolderPath末尾缺少路径分隔符\，拼接文件名时会将日期文件夹名和Office Symbol直接连在一起，系统识别为文件名的一部分；同时未指定.xlsx后缀，可能触发Excel的默认命名规则。

修改方法 #

1. 给sFolderPath末尾添加\，明确路径与文件名的分隔；
2. 给文件名加上.xlsx后缀，确保文件格式正确。

修改代码对应部分：

' 原sFolderPath定义改为
sFolderPath = "C:\\Users\\1023491733A\\Desktop\\TEST\\" & sFolderName & "\\"

' 保存文件部分改为
wb.SaveAs sFolderPath & sFileName & ".xlsx"

问题2：查询结果不稳定，多Office Symbol数据混入 #

原因 #

1. 工作簿重复使用：循环中始终基于同一个模板工作簿修改，未清空旧数据，导致新老数据叠加；
2. 字符串拼接查询的隐患：若OFFICE_SYMBOL包含空格、单引号等特殊字符，直接拼接会导致查询条件失效，匹配到多个结果；
3. 未提前检查记录集为空的情况：当查询无结果时执行MoveFirst会报错，可能中断流程导致数据异常。

修改方法 #

1. 将工作簿创建逻辑移入循环内部，每次处理新的Office Symbol时新建一个模板工作簿，避免数据残留；
2. 使用参数化查询替代字符串拼接，彻底避免特殊字符导致的查询异常，确保筛选精准；
3. 增加记录集非空判断，避免空记录集执行MoveFirst报错。

修改后的完整代码 #

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 xl As Object
    Set xl = CreateObject("Excel.Application")
    xl.Visible = False ' 调试时可改为True
    
    Do While Not OS.EOF
        ' 每次循环新建工作簿
        Dim wb As Object
        Set wb = xl.Workbooks.Add("C:\\Users\\1023491733A\\Desktop\\TEST\\Template.xlsx")
        Dim wr As Object, ws As Object, wt As Object
        Set wr = wb.Worksheets("Airfield")
        Set ws = wb.Worksheets("Fitness")
        Set wt = wb.Worksheets("Leave")
        
        ' 参数化查询Airfield数据
        Dim qdAD As DAO.QueryDef
        Set qdAD = db.CreateQueryDef("", "SELECT [XLS-Airfield].* FROM [XLS-Airfield] WHERE [XLS-Airfield].OFFICE_SYMBOL = @OS;")
        qdAD.Parameters("@OS") = OS.Fields(0)
        Dim AD1 As DAO.Recordset
        Set AD1 = qdAD.OpenRecordset()
        
        ' 参数化查询Fitness数据
        Dim qdPT As DAO.QueryDef
        Set qdPT = db.CreateQueryDef("", "SELECT [XLS-Fitness].* FROM [XLS-Fitness] WHERE [XLS-Fitness].OFFICE_SYMBOL = @OS;")
        qdPT.Parameters("@OS") = OS.Fields(0)
        Dim PT1 As DAO.Recordset
        Set PT1 = qdPT.OpenRecordset()
        
        ' 参数化查询Leave数据
        Dim qdLV As DAO.QueryDef
        Set qdLV = db.CreateQueryDef("", "SELECT [XLS-Leave].* FROM [XLS-Leave] WHERE [XLS-Leave].OFFICE_SYMBOL = @OS;")
        qdLV.Parameters("@OS") = OS.Fields(0)
        Dim LV1 As DAO.Recordset
        Set LV1 = qdLV.OpenRecordset()
        
        ' 写入Airfield工作表
        If Not AD1.EOF Then
            ' 写入表头
            Dim i As Integer
            For i = 0 To AD1.Fields.Count - 1
                wr.Cells(1, i + 1) = AD1.Fields(i).Name
            Next i
            ' 写入数据
            wr.Cells(2, 1).CopyFromRecordset AD1
            ' 格式化
            wr.Rows("1:1").Font.Bold = True
            wr.Cells.EntireColumn.AutoFit
        End If
        
        ' 写入Fitness工作表
        If Not PT1.EOF Then
            For i = 0 To PT1.Fields.Count - 1
                ws.Cells(1, i + 1) = PT1.Fields(i).Name
            Next i
            ws.Cells(2, 1).CopyFromRecordset PT1
            ws.Rows("1:1").Font.Bold = True
            ws.Cells.EntireColumn.AutoFit
        End If
        
        ' 写入Leave工作表
        If Not LV1.EOF Then
            For i = 0 To LV1.Fields.Count - 1
                wt.Cells(1, i + 1) = LV1.Fields(i).Name
            Next i
            wt.Cells(2, 1).CopyFromRecordset LV1
            wt.Rows("1:1").Font.Bold = True
            wt.Cells.EntireColumn.AutoFit
        End If
        
        ' 保存并关闭工作簿
        Dim sFileName As String
        sFileName = OS.Fields(0)
        wb.SaveAs sFolderPath & sFileName & ".xlsx"
        wb.Close SaveChanges:=False
        
        ' 释放当前循环的资源
        Set AD1 = Nothing
        Set PT1 = Nothing
        Set LV1 = Nothing
        Set qdAD = Nothing
        Set qdPT = Nothing
        Set qdLV = Nothing
        Set wb = Nothing
        
        OS.MoveNext
    Loop
    
    ' 清理全局资源
    OS.Close
    xl.Quit
    
    Set OS = Nothing
    Set xl = Nothing
    Set db = Nothing
    Set oFSO = Nothing
    
    MsgBox "Export completed!", vbInformation, "VBAF1"
End Sub

内容的提问来源于stack exchange，提问作者Thian_Sum