每日文件名含动态日期时，Excel跨工作簿数据迁移VBA问题排查

需要实现Excel跨工作簿的剪切粘贴操作，单元格位置固定，仅文件名中的日期每日变更。最初使用固定日期文件名的VBA代码可正常完成操作，但修改为自动获取当前日期的代码后，即使已打开如Generic 15OCT23.csv、Standard 15OCT23.csv这类目标文件，代码仍无法识别到这两个工作簿，请解决此问题。

初始可运行代码 #

ActiveWindow.SmallScroll Down:=108
Windows("Standard 15OCT23.csv").Activate
Range("A2:H17").Select
Selection.Cut
Windows("Generic 15OCT23.csv").Activate
Rows("122:122").Select
Selection.Insert Shift:=xlDown
ActiveWindow.SmallScroll Down:=141

修改后的问题代码 #

Sub StandardToGenericDataXfer()
    Dim sDate As String
    sDate = UCase(format(Date, "ddMMMyy")) ' Format the current date

    Dim standardWorkbook As Workbook
    Dim genericWorkbook As Workbook
    Dim wb As Workbook

    ' Loop through open workbooks
    For Each wb In Workbooks
        Dim wbName As String
        wbName = UCase(wb.Name)
        If (InStr(wbName, "STANDARD") > 0 Or InStr(wbName, "GENERIC") > 0) And _
           InStr(wbName, sDate) > 0 And InStr(wbName, ".CSV") > 0 Then
            If InStr(wbName, "STANDARD") > 0 Then
                Set standardWorkbook = wb
            ElseIf InStr(wbName, "GENERIC") > 0 Then
                Set genericWorkbook = wb
            End If
        End If
    Next wb

    ' Check if both workbooks were found
    If Not (standardWorkbook Is Nothing) And Not (genericWorkbook Is Nothing) Then
        ' Copy data from standardWorkbook to genericWorkbook
        standardWorkbook.Sheets(standardWorkbook.Name).Range("A2:H16").Copy
        genericWorkbook.Sheets(genericWorkbook.Name).Range("A122").Insert Shift:=xlDown
' More Copy/Insert commands here
MsgBox "Data transfer complete.", vbInformation
    Else
        Dim message As String
        message = "One or both workbooks not found:" & vbCrLf
        If Not standardWorkbookFound Then message = message & "Standard workbook not found." & vbCrLf
        If Not genericWorkbookFound Then message = message & "Generic workbook not found."
        MsgBox message, vbExclamation
    End If
End Sub

问题分析与修复方案 #

问题根源 #

1. 未定义变量错误：代码中standardWorkbookFound和genericWorkbookFound从未声明或赋值，导致错误提示逻辑完全失效，甚至可能引发运行时错误。
2. 日期格式区域差异：Format(Date, "ddMMMyy")的输出受系统区域设置影响，若系统为非英文区域（如中文），会生成中文月份缩写（如"10月"），无法匹配文件名中的英文月份（如"OCT"）。
3. 循环匹配逻辑冗余：遍历所有工作簿进行字符串匹配，容易因文件名格式细节（如空格、大小写）导致匹配失败。

修复后的代码 #

Sub StandardToGenericDataXfer()
    Dim sDate As String
    ' 强制使用英文区域生成日期格式，避免系统区域差异
    sDate = UCase(Format$(Date, "ddMMMyy", vbEnglishUS))

    Dim standardFileName As String
    Dim genericFileName As String
    standardFileName = "Standard " & sDate & ".csv"
    genericFileName = "Generic " & sDate & ".csv"

    Dim standardWorkbook As Workbook
    Dim genericWorkbook As Workbook

    ' 直接通过文件名查找工作簿，更高效准确
    On Error Resume Next
    Set standardWorkbook = Workbooks(standardFileName)
    Set genericWorkbook = Workbooks(genericFileName)
    On Error GoTo 0

    ' 检查工作簿是否找到
    If Not standardWorkbook Is Nothing And Not genericWorkbook Is Nothing Then
        ' 执行剪切插入操作，避免激活/选择操作
        standardWorkbook.Sheets(1).Range("A2:H17").Cut
        genericWorkbook.Sheets(1).Rows("122:122").Insert Shift:=xlDown
        ' 更多剪切/插入命令可在此添加
        MsgBox "数据传输完成。", vbInformation
    Else
        Dim message As String
        message = "未找到一个或两个工作簿:" & vbCrLf
        If standardWorkbook Is Nothing Then message = message & "未找到Standard工作簿。" & vbCrLf
        If genericWorkbook Is Nothing Then message = message & "未找到Generic工作簿。"
        MsgBox message, vbExclamation
    End If
End Sub

关键修改点 #

• 改用vbEnglishUS参数强制生成英文日期格式，确保与文件名中的月份缩写匹配。
• 直接通过文件名查找工作簿，替代遍历匹配，减少出错概率且更高效。
• 移除未定义变量，改用Workbook Is Nothing判断工作簿是否找到。
• 取消不必要的Activate和Select操作，VBA操作可直接引用对象，提升代码稳定性和运行速度。

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