Question

我想根据不同的标准过滤和复制表格的行（假设有两个标准）。行应该复制到两个范围内的另一个工作表（如果他们满足第一个标准，则在第一个范围内，如果满足第二个标准则在第二个范围内。

有人能帮助我吗？提前谢谢

西蒙

Answer 1

考虑到多个标准上下文，我建议使用数组将使您的代码更简洁，更容易维护。

假设您需要将输出数据复制到一个工作表：

Sub loopingFilter()
Dim Arr1, Arr2 As Variant
Dim i, j1, j2, St1_Row
Dim St1, St2

Set St1 = Sheets("Input")
Set St2 = Sheets("Output")
St1_Row = St1.Range("A" & Rows.Count).End(xlUp).Row
j1 = 0: j2 = 0

For i = St1_Row To 2 Step -1
'assuming status is your critiria range
Status = St1.Cells(i, 1).Value

If Status = "YourCriteria1" Then
    Arr1(j1) = Range("A" & i & ":Z" & i)
    j1 = j1 + 1 'increment array index     
ElseIf Status = "YourCriteria2" Then
    Arr2(j2) = Range("A" & i & ":Z" & i)
    j2 = j2 + 1 'increment array index       
End If

Next i

'Output array into OUTPUT sheet, if put in one sheet
St2.Range("A1:Z" & j1) = Arr1()
St2.Range("A" & (j1 + 2) & ":Z" & j2) = Arr2()
End Sub

较短版本将使用Ubound，但看起来不像以前那样干净，希望我的回答有帮助：）

Sub loopingFilter1()
ReDim Arr(0) : Dim i, St1_Row : Dim St1, St2
Set St1 = Sheets("Input") : Set St2 = Sheets("Output")
St1_Row = St1.Range("A" & Rows.Count).End(xlUp).Row

For i = 2 to St1_Row
'assuming status is your critiria range
Status = St1.Cells(i, 1).Value
    If Status = "YourCriteria" Then
        Arr(UBound(Arr)) = Range("A" & i & ":Z" & i)
        ReDim Preserve Arr(UBound(Arr) + 1)    
    End if
Next i

St2.Range("A1:Z" & UBound(Arr)) = Arr()
End Sub

VBA - 多次复制已过滤的行

1 个答案: