Excel VBA宏需求：合并带.A后缀工作表指定区域数据（代码失效）

先帮你梳理下原代码里导致无法正常运行的核心问题：

• 数组索引变量i未显式初始化（虽VBA默认值为0，但显式初始化更稳妥）
• 无匹配工作表时，ReDim Preserve ArrWks(i - 1)会触发数组下标越界错误
• 不必要的工作表选中操作，既拖慢速度又容易引发异常
• 未判断汇总工作表Summary是否存在，若不存在会直接报错
• 使用InStr判断名称包含后缀，可能误匹配含该字符串但不是后缀的工作表
• 未关闭屏幕更新，处理大量工作表时运行效率极低

下面是修正后的完整代码：

Sub compile()
    CompileSheetsWithSuffix ".A", ThisWorkbook
End Sub

Sub CompileSheetsWithSuffix(suffix As String, Optional wbk As Workbook)
    Dim wks As Worksheet
    Dim summaryWs As Worksheet
    Dim nextRow As Long
    Dim matchCount As Long
    
    ' 处理可选参数，默认使用当前活动工作簿
    If wbk Is Nothing Then Set wbk = ActiveWorkbook
    
    ' 关闭屏幕更新，大幅提升运行速度
    Application.ScreenUpdating = False
    
    ' 检查汇总表是否存在，不存在则自动新建
    On Error Resume Next
    Set summaryWs = wbk.Worksheets("Summary")
    On Error GoTo 0
    If summaryWs Is Nothing Then
        Set summaryWs = wbk.Worksheets.Add(After:=wbk.Worksheets(wbk.Worksheets.Count))
        summaryWs.Name = "Summary"
    End If
    
    ' 遍历所有工作表，筛选符合后缀要求的表
    For Each wks In wbk.Worksheets
        ' 精确匹配工作表名称后缀，避免误匹配含该字符串的其他名称
        If Right(wks.Name, Len(suffix)) = suffix Then
            ' 获取汇总表的下一个空行
            nextRow = summaryWs.Cells(summaryWs.Rows.Count, 1).End(xlUp).Row + 1
            ' 直接赋值替代复制粘贴，更高效且不占用剪贴板
            summaryWs.Cells(nextRow, 1).Resize(11, 83).Value = wks.Range("D36:CT46").Value
            matchCount = matchCount + 1
        End If
    Next wks
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    
    ' 提示汇总完成信息
    MsgBox "汇总完成！共处理 " & matchCount & " 个符合条件的工作表。", vbInformation
End Sub

关键修改说明： #

• 语义化命名：把SelectSheets改成CompileSheetsWithSuffix，让代码意图更清晰
• 汇总表容错处理：新增检查逻辑，自动创建不存在的Summary表，避免运行报错
• 精确后缀匹配：用Right(wks.Name, Len(suffix)) = suffix替代InStr，确保只匹配以.A结尾的工作表
• 高效赋值方式：使用Resize直接将源区域的值赋值到汇总表，比复制粘贴更高效且无剪贴板依赖
• 简化流程：移除不必要的数组存储和工作表选中操作，代码更简洁易维护
• 用户友好提示：最后弹出消息框显示处理数量，让你清楚汇总结果

修改后，宏就能稳定遍历所有带.A后缀的工作表，将指定区域的数据逐行追加到汇总表中了。

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