遍历工作簿中BT前缀工作表并复制粘贴至汇总表的VBA优化问题

Sub Overzicht_2()
    Dim LR As Long
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim sourceSht As Worksheet
    Dim targetSht As Worksheet: Set targetSht = Blad3 ' 汇总表（荷兰语Sheet3）
    
    Application.ScreenUpdating = False
    
    ' 遍历工作簿中所有工作表
    For Each sourceSht In wb.Worksheets
        ' 判断当前工作表名称是否以"BT"开头
        If Left(sourceSht.Name, 2) = "BT" Then
            ' 复制第一个区域 B11:V170
            sourceSht.Range("B11:V170").Copy
            LR = targetSht.Cells(targetSht.Rows.Count, "B").End(xlUp).Row
            targetSht.Range("B" & LR).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            
            ' 复制第二个区域 B176:V205
            sourceSht.Range("B176:V205").Copy
            LR = targetSht.Cells(targetSht.Rows.Count, "B").End(xlUp).Row
            targetSht.Range("B" & LR).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            
            ' 复制第三个区域 B211:V290
            sourceSht.Range("B211:V290").Copy
            LR = targetSht.Cells(targetSht.Rows.Count, "B").End(xlUp).Row
            targetSht.Range("B" & LR).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        End If
    Next sourceSht
    
    Application.CutCopyMode = False ' 清除复制状态
    Application.ScreenUpdating = True
    
    ' 回到Blad1的B3单元格（不需要可删除）
    Blad1.Range("B3").Activate
End Sub

关键修改点 #

• 批量适配BT开头工作表：原代码仅指定单个"BT"表，现在通过遍历所有工作表+前缀判断，自动处理任意数量的BT开头工作表。
• 彻底移除Select/Selection：所有粘贴操作直接通过目标工作表的单元格对象执行，避免因当前激活表变化导致的错误，同时提升运行效率。
• 修正循环变量错误：原代码循环结束语句Next d与循环变量i不匹配，改用For Each遍历更直观，避免编译报错。
• 统一目标表引用：提前将Blad3赋值给变量targetSht，代码更简洁，也避免重复书写。
• 清理复制状态：添加Application.CutCopyMode = False，消除复制区域的虚线框残留。

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