VBA批量处理文件夹及子文件夹Excel插入列仅当前文件生效求助

核心错误点 #

• 你编写的InsertCol过程中With wb块未配合.调用内部属性，相当于该语句完全未生效，无前置限定的Worksheets、Columns、Range默认指向代码所在的工作簿，ActiveWorkbook也会因为窗口焦点问题指向错误对象，导致只有存代码的文件被修改
• 原生Dir函数仅支持遍历单层目录，无法满足你要求的包含子文件夹的遍历需求
• 大量使用Select、Activate这类依赖窗口焦点的不稳定操作，容易出现逻辑异常

修复后完整代码 #

1. 支持递归遍历子文件夹的循环过程 #

Sub LoopAllFiles()
    Dim Pathname As String
    Pathname = "C:\scriptest\" ' 修改为你的目标根文件夹路径
    Call ProcessFolder(Pathname)
End Sub

' 递归处理文件夹及子文件夹
Sub ProcessFolder(ByVal folderPath As String)
    Dim fso As Object, folder As Object, subFolder As Object
    Dim wb As Workbook, fileName As String
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)
    
    ' 处理当前文件夹内的目标文件
    fileName = Dir(folderPath & "*2021.xlsm")
    Do While fileName <> ""
        Set wb = Workbooks.Open(folderPath & fileName)
        Call InsertCol(wb)
        wb.Close SaveChanges:=True
        fileName = Dir()
    Loop
    
    ' 递归处理所有子文件夹
    For Each subFolder In folder.SubFolders
        Call ProcessFolder(subFolder.Path & "\")
    Next subFolder
    
    Set fso = Nothing
End Sub

2. 修复后的列插入过程 #

Sub InsertCol(wb As Workbook)
    Dim ws As Worksheet
    ' 显式绑定目标工作簿的指定工作表，避免指向错误
    Set ws = wb.Worksheets("colours")
    
    With ws
        ' 不需要Select/Activate，直接操作对象
        .Columns("E:E").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        .Range("E2").Value = "RED"
        .Range("F2").Value = "GREEN"
        ' 直接复制格式，不需要选中
        .Range("F2").Copy
        .Range("E2").PasteSpecial Paste:=xlPasteFormats
        Application.CutCopyMode = False
    End With
End Sub

注意事项 #

• 如果不需要遍历子文件夹，只需要替换原来的InsertCol过程即可解决仅修改代码文件的问题
• 运行前确认所有目标文件都存在名为colours的工作表，否则会触发运行时错误
• 运行代码时不要手动切换Excel窗口，避免打开的文件焦点异常

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