Excel VBA循环复制粘贴、自动筛选及返回结果功能故障排查

原问题场景 #

工作簿包含Sheet1和名称为"1"至"15"的工作表：

• Sheet1存储主数据，需遍历每行，用G列的值匹配对应名称的工作表
• 将该行数据粘贴到匹配的工作表后，调用FilterX宏执行筛选
• 把筛选后的结果行数写回Sheet1对应行的H列

原错误代码 #

Sub DataAnalysis()

    Sub ArrayBuilder() 'Loops through all rows and copy
        myarray = Range("A1:M1000")
        
        For i = 1 To UBound(myarray)
            For j = 1 To UBound(myarray, 2)
                Debug.Print (myarray(i, j))
            Next j
        Next i
            
        Dim wkSht As Worksheet
        For Each wkSht In Sheets
            X = Range("G1:G1000")
            
            For i = 1 To UBound(myarray)
                For j = 1 To UBound(myarray, 2)
                    Debug.Print (myarray(i, j))
                Next j
            Next i
            
            If Sheets("Sheet1").Range(X).Value = wkSht.Name Then  'if value of G in rows (that has been looped through)
                'matches the worksheet name, then paste
                Sheets("Sheet1").Rows("2:2").Paste
                Application.CutCopyMode = False
            End If
        Next
    
        Application.Run "'FileX.xls'!FilterX"    ' this activates a macro for autofilter and run it, 

        ' I can also paste the code here but that is not the problem right now
        X1 = Range("H1:H1000")
       
        For i = 1 To UBound(myarray)
            For j = 1 To UBound(myarray, 2)
                Debug.Print (myarray(i, j))
            Next j
        Next i
        
        Sheet1.Range(X1).Value = ws.AutoFilter.Range.Columns(1) ' returns the row count on the filtered data to cell H for every loop
    End Sub

End Sub

补充的FilterX宏代码 #

Sub FilterX()
    If ActiveSheet.FilterMode = True Then
    ActiveSheet.ShowAllData
    End If
    
    Dim L(2) As String
    Dim M(2) As String
    Dim N(2) As String
    Dim O(2) As String
    Dim P(2) As String
    Dim Q(2) As String
    Dim R(2) As String
    Dim T(2) As String
    Dim U(2) As String
    Dim V(2) As String
    Dim W(2) As String
    Dim X(2) As String
    Dim Y(2) As String
    Dim Z(2) As String    
        
        L(0) = Cells(2, 12).Value
        L(1) = Cells(2, 12).Value + 1
        L(2) = Cells(2, 12).Value - 1
        
        M(0) = Cells(2, 13).Value
        M(1) = Cells(2, 13).Value + 1
        M(2) = Cells(2, 13).Value - 1
        
        N(0) = Cells(2, 14).Value
        N(1) = Cells(2, 14).Value + 1
        N(2) = Cells(2, 14).Value - 1
        
        O(0) = Cells(2, 15).Value
        
        P(0) = Cells(2, 16).Value
        P(1) = Cells(2, 16).Value + 1
        P(2) = Cells(2, 16).Value - 1
        
        Q(0) = Cells(2, 17).Value
        Q(1) = Cells(2, 17).Value + 1
        Q(2) = Cells(2, 17).Value - 1
        
        R(0) = Cells(2, 18).Value
        R(1) = Cells(2, 18).Value + 1
        R(2) = Cells(2, 18).Value - 1
        
        
        T(0) = Cells(2, 20).Value
        T(1) = Cells(2, 20).Value + 1
        T(2) = Cells(2, 20).Value - 1
        
        U(0) = Cells(2, 21).Value
        U(1) = Cells(2, 21).Value + 1
        U(2) = Cells(2, 21).Value - 1
        
        
        V(0) = Cells(2, 22).Value
        V(1) = Cells(2, 22).Value + 1
        V(2) = Cells(2, 22).Value - 1
        
        W(0) = Cells(2, 23).Value
        
        X(0) = Cells(2, 24).Value
        X(1) = Cells(2, 24).Value + 1
        X(2) = Cells(2, 24).Value - 1
        
        
                
        Y(0) = Cells(2, 25).Value
        Y(1) = Cells(2, 25).Value + 1
        Y(2) = Cells(2, 25).Value - 1
        
        Z(0) = Cells(2, 26).Value
        Z(1) = Cells(2, 26).Value + 1
        Z(2) = Cells(2, 26).Value - 1
        
        
    'ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=12, Operator:=xlFilterValues, Criteria1:=L()
    ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=13, Operator:=xlFilterValues, Criteria1:=M()
    'ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=14, Operator:=xlFilterValues, Criteria1:=N()
    ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=15, Operator:=xlFilterValues, Criteria1:=O()
    'ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=16, Operator:=xlFilterValues, Criteria1:=P()
    'ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=17, Operator:=xlFilterValues, Criteria1:=Q()
    ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=18, Operator:=xlFilterValues, Criteria1:=R()
    'ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=20, Operator:=xlFilterValues, Criteria1:=T()
    ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=21, Operator:=xlFilterValues, Criteria1:=U()
    'ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=22, Operator:=xlFilterValues, Criteria1:=V()
    ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=23, Operator:=xlFilterValues, Criteria1:=W()
    'ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=24, Operator:=xlFilterValues, Criteria1:=X()
    'ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=25, Operator:=xlFilterValues, Criteria1:=Y()
    ActiveSheet.Range("A1:AZ1048576").AutoFilter Field:=26, Operator:=xlFilterValues, Criteria1:=Z()
              
End Sub

原代码问题分析 #

1. 嵌套Sub非法：VBA不允许在一个Sub内部定义另一个Sub（ArrayBuilder嵌套在DataAnalysis里）
2. 未限定工作表的Range引用：所有Range/Cells调用都没指定工作表，会默认使用ActiveSheet，导致逻辑混乱
3. 逻辑错误：
   • 没有Copy操作就直接Paste，完全无效
   • X = Range("G1:G1000")把整个单元格区域赋值给变量，后续判断Sheets("Sheet1").Range(X).Value完全错误
   • 未定义ws变量就调用ws.AutoFilter.Range，会直接报错
4. 冗余代码：多次无意义遍历数组并Debug.Print，完全不影响业务逻辑

修复后的完整DataAnalysis宏 #

Sub DataAnalysis()
    Dim mainWs As Worksheet
    Dim targetWs As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim filterRowCount As Long
    
    ' 定义主数据工作表
    Set mainWs = ThisWorkbook.Sheets("Sheet1")
    ' 获取Sheet1最后一行（避免固定1000行的限制）
    lastRow = mainWs.Cells(mainWs.Rows.Count, "G").End(xlUp).Row
    
    ' 遍历Sheet1的每一行（从第2行开始，假设第1行是表头）
    For i = 2 To lastRow
        ' 获取当前行G列对应的工作表名称
        Dim targetSheetName As String
        targetSheetName = mainWs.Cells(i, "G").Value
        
        ' 检查目标工作表是否存在
        On Error Resume Next
        Set targetWs = ThisWorkbook.Sheets(targetSheetName)
        On Error GoTo 0
        
        If Not targetWs Is Nothing Then
            ' 复制当前行数据到目标工作表的第2行（覆盖原有筛选条件行）
            mainWs.Rows(i).Copy targetWs.Rows(2)
            Application.CutCopyMode = False
            
            ' 激活目标工作表并调用FilterX宏
            targetWs.Activate
            Application.Run "'FileX.xls'!FilterX"
            
            ' 计算筛选后的可见行数（排除表头）
            If targetWs.AutoFilterMode Then
                filterRowCount = targetWs.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
            Else
                ' 如果没有筛选，返回总行数（排除表头）
                filterRowCount = targetWs.Cells(targetWs.Rows.Count, "A").End(xlUp).Row - 1
            End If
            
            ' 将结果写入Sheet1当前行的H列
            mainWs.Cells(i, "H").Value = filterRowCount
            
            ' 清空targetWs变量，避免下一次循环出错
            Set targetWs = Nothing
        Else
            ' 如果工作表不存在，H列标记错误
            mainWs.Cells(i, "H").Value = "工作表不存在"
        End If
    Next i
    
    ' 回到Sheet1
    mainWs.Activate
    MsgBox "数据分析完成！", vbInformation
End Sub

关键修改说明 #

1. 移除嵌套Sub：把原ArrayBuilder的逻辑整合到主Sub中，符合VBA语法规范
2. 明确工作表引用：所有单元格操作都指定mainWs或targetWs，避免ActiveSheet切换导致的错误
3. 动态获取最后一行：用lastRow = mainWs.Cells(mainWs.Rows.Count, "G").End(xlUp).Row替代固定1000行，适配实际数据量
4. 完善工作表存在性检查：用On Error Resume Next捕获工作表不存在的情况，避免报错
5. 正确的复制粘贴逻辑：先Copy当前行，再Paste到目标工作表的第2行（匹配FilterX读取第2行数据的逻辑）
6. 准确计算筛选行数：用SpecialCells(xlCellTypeVisible).Count获取可见行数，减去1排除表头
7. 错误处理：工作表不存在时在H列标记提示信息

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