VBA工作表循环仅停留活动表，无法遍历指定工作表问题排查

背景 #

• 工作簿包含1至n个结构统一的可见工作表，作为第三方定价/签约的标准填写模板（带下拉选项）
• 隐藏的"Lookup"工作表可提取模板中Range("D7:E28")的用户选择，进行动态查询，结果随模板内容变化

目标 #

生成"Summary List"可见工作表，汇总所有模板工作表的查询结果：

• 每个工作表的结果用边框分隔，标注对应工作表名
• 最终将"Summary List"移至工作簿末尾并设为可见

现有代码尝试 #

Dim ws As Worksheet
    'Dim rngNm As Range: Set rngNm = Range("A4")
    'Dim rngLU As Range: Set rngLU = Range("D7:E28")
    Dim lookupWS As Worksheet: Set lookupWS = Sheets("Lookup")
    Dim SummaryCodeWS As Worksheet: Set SummaryCodeWS = Sheets("Summary List")
    Dim lookupLR As Long: lookupLR = lookupWS.Range("K10000").End(xlUp).Row
    Dim summaryLR As Long: summaryLR = SummaryCodeWS.Range("B10000").End(xlUp).Row

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    For Each ws In ActiveWorkbook.Worksheets
        'With ws
            If ws.Visible = xlSheetVisible And ws.Name <> " " Then
  
                'summary ws obt ea. ws name
                SummaryCodeWS.Range("A" & summaryLR).Offset(2, 0).Value = [A4].Value  
                'Have also ran it as = rngNm (reads) / = ws.Range("A4").Value (doesn't read)
                         
                'Master list obt ea. term & code type for lookup
                lookupWS.Range("G3:H24").Value = [D7:E28].Value 
                'have also ran it as = rngLU (doesn't read) / = ws.Range("D7:E28").Value (doesn't read)
        
                'Copy/paste LU table into summary ws
                lookupWS.Range("K4:O" & lookupLR).Copy
                SummaryCodeWS.Range("B" & summaryLR).Offset(2, 0).PasteSpecial xlPasteValues
                Application.CutCopyMode = False
                                    
                'Add border to ea. range
                With SummaryCodeWS.Range("A" & summaryLR, "F" & summaryLR).Offset(2, 0).Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .Weight = xlThin
                    .ColorIndex = xlAutomatic
                End With
                
                'MsgBox ws.Name  'Testing loop: currently working as it reads all sheets
    
            End If
        'End With
    Next ws
    
    'Make Code Summ vis (loc: end of wb)
    With SummaryCodeWS
        .Visible = xlSheetVisible
        .Move After:=Sheets(Sheets.Count)
    'End With
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

问题现象 #

• 循环内的MsgBox ws.Name能正确弹出所有可见工作表名称，说明遍历逻辑生效
• "Summary List"要么无数据，要么仅显示单个工作表的查询结果，无法完成全表汇总

核心问题分析 #

1. 未指定工作表的Range引用错误：[A4]、[D7:E28]这种写法默认指向当前活动工作表，而非循环中的ws，导致读取数据错误
2. 未在循环内更新关键行号：summaryLR和lookupLR仅在循环前初始化，每次循环都用同一行号，导致新数据覆盖旧数据，或写入到错误位置
3. Lookup结果行号未实时更新：每次更新Lookup区域后，未重新获取查询结果的最新行数，导致复制的范围不准确
4. 语法错误：SummaryCodeWS的With语句未闭合，可能导致后续代码执行异常
5. 未排除系统工作表：循环未排除"Lookup"和"Summary List"本身，可能误处理这两个表

修正后的代码（无Activate） #

Dim ws As Worksheet
Dim lookupWS As Worksheet: Set lookupWS = ThisWorkbook.Sheets("Lookup")
Dim SummaryCodeWS As Worksheet: Set SummaryCodeWS = ThisWorkbook.Sheets("Summary List")
Dim lookupLR As Long
Dim summaryLR As Long
Dim pasteRow As Long

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

' 初始化汇总表起始行（跳过表头，假设表头在1-2行）
summaryLR = SummaryCodeWS.Range("B" & SummaryCodeWS.Rows.Count).End(xlUp).Row

For Each ws In ThisWorkbook.Worksheets
    ' 排除系统工作表和空名称工作表
    If ws.Visible = xlSheetVisible _
        And ws.Name <> "Lookup" _
        And ws.Name <> "Summary List" _
        And Trim(ws.Name) <> "" Then
        
        ' 1. 写入当前工作表名称到汇总表
        pasteRow = summaryLR + 2
        SummaryCodeWS.Range("A" & pasteRow).Value = ws.Range("A4").Value
        
        ' 2. 更新Lookup区域的数据源
        lookupWS.Range("G3:H24").Value = ws.Range("D7:E28").Value
        
        ' 3. 重新获取Lookup结果的最新行数（确保取到动态更新后的结果）
        lookupLR = lookupWS.Range("K" & lookupWS.Rows.Count).End(xlUp).Row
        
        ' 4. 复制Lookup结果到汇总表
        lookupWS.Range("K4:O" & lookupLR).Copy
        SummaryCodeWS.Range("B" & pasteRow).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        
        ' 5. 添加分隔边框（覆盖当前结果区域的顶部）
        With SummaryCodeWS.Range("A" & pasteRow, "F" & pasteRow + lookupLR - 4).Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        
        ' 6. 更新汇总表下一次写入的起始行
        summaryLR = pasteRow + lookupLR - 4
    End If
Next ws

' 显示并移动汇总表到末尾
With SummaryCodeWS
    .Visible = xlSheetVisible
    .Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
End With

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With

关键修改说明 #

• 所有Range引用都明确指定工作表（ws.Range、lookupWS.Range等），避免依赖活动工作表
• 在每次循环内重新计算lookupLR，确保获取动态查询后的最新结果行数
• 新增pasteRow变量管理每次写入的起始位置，循环结束后更新summaryLR为当前最后一行，保证数据追加而非覆盖
• 排除"Lookup"和"Summary List"工作表，避免无效处理
• 修正边框范围，覆盖当前工作表结果的整个区域顶部
• 闭合所有With语句，修复语法错误
• 使用ThisWorkbook替代ActiveWorkbook，确保操作目标是当前代码所在工作簿，避免误操作其他打开的工作簿

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