Excel更新后跨实例VBA无法识别CSV文件的解决咨询

公司更新Excel后，原VBA代码失效。从外部程序打开的12345.csv会在独立Excel实例中启动，导致宏所在的「New Member Enrollments.xlsm」无法识别该文件。需求是从这个.csv提取数据到宏工作簿，提取后关闭.csv即可。当前环境为Windows 11 + 最新版Excel，原代码如下：

Sub GetData()

    Dim wb As Workbook ''Source workbook
    Dim wb1 As Workbook '''Destination workbook
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    
    Set wb1 = Workbooks("New Member Enrollments.xlsm")

    'Check if exactly 2 workbooks are currently open    ''''**This is where I am having issues**.  It is not seeing the workbook.****
    If Application.Workbooks.Count <> 2 Then
        MsgBox "ERROR - There are [" & Application.Workbooks.Count & "] workbooks open." & Chr(10) & _
               "There must be two workbooks open:" & Chr(10) & _
               "-The source workbook (old template)" & Chr(10) & _
               "-The destination workbook"
        Exit Sub
    End If

    For Each wb In Application.Workbooks
        If Right(wb.Name, 4) = ".csv" Then
            'Workbook name ends in number(s), this is the source workbook that will be copied from
            'You'll need to specify which sheet you're working with, this example code assumes the activesheet of that workbook
            Set wsSource = wb.ActiveSheet
        Else
            'Workbook name does not end in number(s), this is the source workbook that will be pasted to
            'You'll need to specify which sheet you're working with, this example code assumes the activesheet of that workbook
            Set wsDest = wb1.Sheets("Company Enrollments")
        End If
    Next wb

    'Check if both a source and destination were assigned
    If wsSource Is Nothing Then
        MsgBox "ERROR - Unable to find valid source workbook to copy data from"
        Exit Sub
    ElseIf wsDest Is Nothing Then
        MsgBox "ERROR - Unable to find valid destination workbook to paste data into"
        Exit Sub
    End If

    'The first dimension is for how many times you need to define source and dest ranges, the second dimension should always be 1 to 2
    Dim aFromTo(1 To 2, 1 To 2) As Range
    'Add source copy ranges here:                       'Add destination paste ranges here
    wsSource.Activate
    
    'Range("A5", Range("A5").End(xlDown)).Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlNo

    
    Set aFromTo(1, 1) = wsSource.Range("A5:P5", Range("A5:P5").End(xlDown)):       Set aFromTo(1, 2) = wsDest.Range("A2")
    Set aFromTo(2, 1) = wsSource.Range("A5:P5"):      Set aFromTo(2, 2) = wsDest.Range("A2")
    
    'This will loop through the array of specified FromTo ranges and will ensure that only values are brought over
    Dim i As Long
    For i = LBound(aFromTo, 1) To UBound(aFromTo, 1)
        aFromTo(i, 2).Resize(aFromTo(i, 1).Rows.Count, aFromTo(i, 1).Columns.Count).Value = aFromTo(i, 1).Value
    Next i
     
Application.CutCopyMode = False
    
ActiveWorkbook.Close SaveChanges:=False

    wsDest.Activate
    
Columns("D:G").Delete
Columns("F").Delete

Range("D2").Activate
    ActiveWorkbook.Worksheets("Company Enrollments").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Company Enrollments").Sort.SortFields.Add Key:= _
        Range("D2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Company Enrollments").Sort
        .SetRange Range("A2:K1041")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Application.CutCopyMode = False

Range("A1").Select

Worksheets("Company Enrollments").Activate

Call AddColumnHeaders
End Sub

原代码的核心问题是仅遍历当前Excel实例的工作簿，而.csv在独立实例中打开，因此无法被检测到。以下是修改后的代码，解决跨实例识别文件的问题：

Sub GetData_Fixed()
    Dim wb1 As Workbook ' 目标工作簿（宏所在文件）
    Dim wsDest As Worksheet ' 目标工作表
    Dim xlApp As Object ' 用于遍历Excel实例
    Dim wbSource As Workbook ' 源CSV工作簿
    Dim wsSource As Worksheet ' 源CSV工作表
    Dim foundCSV As Boolean
    
    ' 绑定宏所在的工作簿
    On Error Resume Next
    Set wb1 = Workbooks("New Member Enrollments.xlsm")
    On Error GoTo 0
    If wb1 Is Nothing Then
        MsgBox "错误：未找到宏所在工作簿「New Member Enrollments.xlsm」"
        Exit Sub
    End If
    Set wsDest = wb1.Sheets("Company Enrollments")
    
    ' 遍历所有Excel实例，寻找目标CSV
    foundCSV = False
    For Each xlApp In GetObject(, "Excel.Application").Workbooks.Application ' 遍历所有Excel实例
        For Each wbSource In xlApp.Workbooks
            If wbSource.Name = "12345.csv" Then ' 精准匹配CSV文件名
                Set wsSource = wbSource.ActiveSheet
                foundCSV = True
                Exit For
            End If
        Next wbSource
        If foundCSV Then Exit For
    Next xlApp
    
    ' 检查是否找到CSV
    If Not foundCSV Then
        MsgBox "错误：未找到「12345.csv」文件"
        Exit Sub
    End If
    
    ' 复制数据（保留原逻辑）
    Dim aFromTo(1 To 2, 1 To 2) As Range
    Set aFromTo(1, 1) = wsSource.Range("A5:P5", wsSource.Range("A5:P5").End(xlDown))
    Set aFromTo(1, 2) = wsDest.Range("A2")
    Set aFromTo(2, 1) = wsSource.Range("A5:P5")
    Set aFromTo(2, 2) = wsDest.Range("A2")
    
    ' 仅复制值
    Dim i As Long
    For i = LBound(aFromTo, 1) To UBound(aFromTo, 1)
        aFromTo(i, 2).Resize(aFromTo(i, 1).Rows.Count, aFromTo(i, 1).Columns.Count).Value = aFromTo(i, 1).Value
    Next i
    
    ' 关闭CSV文件（不保存）
    wbSource.Close SaveChanges:=False
    
    ' 后续处理逻辑（保留原逻辑）
    wsDest.Activate
    wsDest.Columns("D:G").Delete
    wsDest.Columns("F").Delete
    
    ' 排序
    With wsDest.Sort
        .SortFields.Clear
        .SortFields.Add Key:=wsDest.Range("D2"), SortOn:=xlSortOnValues, Order:=xlAscending
        .SetRange wsDest.Range("A2:K1041")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    wsDest.Range("A1").Select
    Call AddColumnHeaders
End Sub

关键修改点 #

• 新增遍历所有Excel实例的逻辑，确保能找到在独立实例中打开的.csv
• 直接通过文件名12345.csv精准匹配，不再依赖工作簿数量检查（避免多开文件导致的错误）
• 移除原代码中依赖ActiveWorkbook的不稳定逻辑，改用明确绑定的工作簿对象
• 增加错误检测，确保宏所在工作簿存在

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