VBA中Array/Ubound偶发失效：无法始终返回完整数组

问题背景 #

我有多个可见工作表，每个表的D7:E28区域用户输入内容会被同步到隐藏的Lookup工作表，通过该表内的交叉引用匹配后，结果要依次写入Summary List工作表。

问题现象 #

调试时，增减用户输入的值有时能重置并生成完整的汇总结果；但在用户选择未更改的情况下重复运行宏，数组会缩短，仅返回第一个或前两个值。调整UBound参数无法解决问题。

原代码 #

Sub WS_Lookup()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim LookupWS As Worksheet
    Dim SummaryCodeWS As Worksheet
    Dim lookupLR As Long
    Dim summaryRow As Range
    Dim arr As Variant
    
    Set wb = ActiveWorkbook
    Set LookupWS = wb.Worksheets("Lookup")
    Set SummaryCodeWS = wb.Worksheets("Summary List")
    lookupLR = LookupWS.Range("K10000").End(xlUp).Row
                
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    For Each ws In wb.Worksheets
        If ws.Visible = xlSheetVisible And ws.Name <> " " Then
                    
            Set summaryRow = SummaryCodeWS.Range("B10000").End(xlUp).Offset(2).EntireRow
            summaryRow.Columns("A").Value = ws.Range("A4").Value
                    
            LookupWS.Range("G3:H24").Value = ws.Range("D7:E28").Value
                    
            arr = LookupWS.Range("K4:O" & lookupLR).Value
            summaryRow.Columns("B").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr 
                                  
            With summaryRow.Range("A1:F1").Borders(xlEdgeTop)
                 .LineStyle = xlContinuous
                 .Weight = xlThin
                 .ColorIndex = xlAutomatic
            End With
            
         End If
    Next ws
    
    With SummaryCodeWS
        .Visible = xlSheetVisible
        .Move After:=Sheets(Sheets.Count)
    End With
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
End Sub

问题根源 #

1. lookupLR仅初始化一次：代码开头就计算了Lookup表K列的最后一行，但每次循环处理不同工作表时，Lookup!G3:H24被更新后，K列的匹配结果行数可能变化，此时旧的lookupLR无法反映最新的有效数据行数，导致数组只取到旧的范围。
2. 公式未强制刷新：如果Lookup表的K列及后续列使用公式计算匹配结果，写入G3:H24后可能未自动完成计算，导致取数组时数据还未更新，行数错误。
3. 最后一行定位不够可靠：使用Range("K10000").End(xlUp).Row定位最后一行，若数据超过10000行会失效，且可能因空白行导致定位错误。

修复方案 #

• 将lookupLR的计算移到循环内部，每次处理新工作表后重新获取K列最新的最后一行
• 在获取数组前强制Lookup工作表刷新计算，确保公式结果更新
• 改用更可靠的最后一行定位方式：LookupWS.Cells(LookupWS.Rows.Count, "K").End(xlUp).Row

修复后代码 #

Sub WS_Lookup()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim LookupWS As Worksheet
    Dim SummaryCodeWS As Worksheet
    Dim lookupLR As Long
    Dim summaryRow As Range
    Dim arr As Variant
    
    Set wb = ActiveWorkbook
    Set LookupWS = wb.Worksheets("Lookup")
    Set SummaryCodeWS = wb.Worksheets("Summary List")
                
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual ' 暂时手动计算提升效率
    End With
    
    For Each ws In wb.Worksheets
        If ws.Visible = xlSheetVisible And ws.Name <> " " Then
            ' 定位Summary的下一行（改用A列定位更准确，避免B列空值影响）
            Set summaryRow = SummaryCodeWS.Cells(SummaryCodeWS.Rows.Count, "A").End(xlUp).Offset(2).EntireRow
            summaryRow.Columns("A").Value = ws.Range("A4").Value
            
            ' 更新Lookup的输入区域
            LookupWS.Range("G3:H24").Value = ws.Range("D7:E28").Value
            
            ' 强制刷新Lookup的公式计算
            LookupWS.Calculate
            ' 重新获取K列最新的最后一行
            lookupLR = LookupWS.Cells(LookupWS.Rows.Count, "K").End(xlUp).Row
            
            ' 仅当有有效数据时才写入数组
            If lookupLR >= 4 Then
                arr = LookupWS.Range("K4:O" & lookupLR).Value
                summaryRow.Columns("B").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
            End If
            
            ' 添加顶部边框
            With summaryRow.Range("A1:F1").Borders(xlEdgeTop)
                 .LineStyle = xlContinuous
                 .Weight = xlThin
                 .ColorIndex = xlAutomatic
            End With
            
         End If
    Next ws
    
    With SummaryCodeWS
        .Visible = xlSheetVisible
        .Move After:=wb.Sheets(wb.Sheets.Count)
    End With
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic ' 恢复自动计算
    End With
    
End Sub

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