遍历文件夹复制前缀为AB的CSV文件时循环异常求助

问题根源分析 #

你的代码出现死循环重复复制第二个文件，核心原因是Dir函数的错误使用，同时伴随变量名、路径处理和冗余循环的问题：

• Dir函数调用逻辑错误：内层While Dir(abfilepath) <> ""每次调用都会重新匹配通配符路径，始终返回第一个符合条件的文件，永远无法遍历到下一个文件，直接导致死循环。
• 变量名拼写错误：循环末尾更新文件时用了swfilename = Dir()，但实际应该用abfilename = Dir()，变量名错误导致无法获取下一个文件。
• 文件路径不明确：abfilepath = filepath & "AB" & "*"是通配符路径，不是单个文件的具体路径，打开文件时会重复匹配第一个文件。
• 外层冗余循环：最外层的Do Until Dir(filepath & "*") = ""完全多余，会重复执行内层遍历逻辑，加重死循环问题。
• 变量声明不规范：在循环内部声明ws、csv等变量，虽不报错但易造成逻辑混淆，建议移到循环外统一声明。

修正后的代码 #

Sub CopyABCSVs()
    Dim filepath As String
    Dim abfilename As String
    Dim abfilepath As String
    Dim ws As Worksheet, csv As Workbook
    Dim abfilename_stripped As String
    
    ' 请确保filepath已正确赋值，示例：filepath = "D:\YourCSVFolder\"
    abfilename = Dir(filepath & "AB*.csv") ' 首次调用Dir获取第一个AB前缀CSV
    
    ' 无匹配文件时提示退出
    If Len(abfilename) = 0 Then
        MsgBox "数据文件夹中没有AB前缀的CSV文件"
        Exit Sub
    End If
    
    ' 遍历所有AB前缀CSV
    Do While abfilename <> ""
        abfilename_stripped = Replace(abfilename, ".csv", "")
        
        ' 检查工作表是否存在，不存在则新建
        On Error Resume Next
        Set ws = ThisWorkbook.Sheets(abfilename_stripped)
        On Error GoTo 0
        If ws Is Nothing Then
            Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            ws.Name = abfilename_stripped
        End If
        
        ' 获取单个文件的具体路径
        abfilepath = filepath & abfilename
        ' 打开CSV并复制数据
        Set csv = Workbooks.Open(abfilepath, Local:=True)
        csv.ActiveSheet.Range("A:Z").Copy
        ws.Range("A1").PasteSpecial xlPasteValues
        ' 关闭CSV且不保存
        csv.Close SaveChanges:=False
        
        ' 获取下一个匹配文件
        abfilename = Dir()
    Loop
End Sub

修正说明 #

1. 采用Dir函数的正确用法：首次调用带通配符参数获取第一个文件，后续用无参数Dir()遍历下一个文件，直到返回空字符串结束循环。
2. 新增工作表存在性判断，避免因工作表不存在导致的运行时错误。
3. 直接通过Workbooks.Open()获取工作簿对象，替代ActiveWorkbook，逻辑更可靠。
4. 关闭CSV文件时添加SaveChanges:=False，避免弹出不必要的保存提示。

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