根据单元格值将数据从特定列复制到另一个工作表

Question

我是 VBA 的新手，我正在尝试使用一个宏来复制特定列中的数据，如果该行符合特定标准。

虽然原始文档有更多列，但基本前提是我已经将数据输入到 A 到 F。如果 F 中的值为 Yes，那么我想将 A 列 C 和 E 中的数据复制到 A 中的另一张表， B 和 C 分别。

我不想删除原始数据，而是留在页面上。

我一直在使用下面的代码，我试图从另一个代码中更新它，但它使用的是 UsedRange，所以我试图删除它并只使用最后一行。

Sub MoveData_Confirmed()

    Dim xRg As Range
    Dim xCell As Range
    Dim i As Long
    Dim J As Long
    Dim K As Long
    i = Sheets("BP - Running Sheet").Cells(Rows.Count, "B").End(xlUp).Row
    J = Sheets("Running Sheet").Cells(Rows.Count, "B").End(xlUp).Row
    If J = 1 Then
    If Application.WorksheetFunction.CountA(Worksheets("Running Sheet").UsedRange = 0 Then J = 0
    End If
    Set xRg = Worksheets("BP - Running Sheet").Range("W2:W" & i)
    On Error Resume Next
    Application.ScreenUpdating = False
    For K = 1 To xRg.Count
        If CStr(xRg(K).Value) = "Yes" Then
            xRg(K).Range("B:D").Copy
            Worksheets("Running Sheet").Range("A" & J + 1).PasteSpecial Paste:=xlPasteValues
            xRg(K).Range("F:F").Copy
            Worksheets("Running Sheet").Range("D" & J + 1).PasteSpecial Paste:=xlPasteValues
            xRg(K).Range("I:I").Copy
            Worksheets("Running Sheet").Range("F" & J + 1).PasteSpecial Paste:=xlPasteValues
            xRg(K).Range("K:K").Copy
            Worksheets("Running Sheet").Range("G" & J + 1).PasteSpecial Paste:=xlPasteValues
            xRg(K).Range("N:N").Copy
            Worksheets("Running Sheet").Range("I" & J + 1).PasteSpecial Paste:=xlPasteValues
            xRg(K).Range("O:O").Copy
            Worksheets("Running Sheet").Range("J" & J + 1).PasteSpecial Paste:=xlPasteValues
            xRg(K).Range("P:P").Copy
            Worksheets("Running Sheet").Range("K" & J + 1).PasteSpecial Paste:=xlPasteValues
            xRg(K).Range("Q:Q").Copy
            Worksheets("Running Sheet").Range("M" & J + 1).PasteSpecial Paste:=xlPasteValues
            xRg(K).Range("V:V").Copy
            Worksheets("Running Sheet").Range("H" & J + 1).PasteSpecial Paste:=xlPasteValues
            J = J + 1
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Answer 1

我发现 arrays 更好更快地处理：

Option Explicit
Sub MoveData()

    Dim InputArray
    Dim OutputArray
    Dim I As Integer
    Dim N As Integer
    Dim CNT As Integer
    Dim CheckRow As Integer
    Dim LastCol As Integer
    Dim RunningSheet As Worksheet
    Dim BP_RunningSheet As Worksheet
    
    Worksheets("BP - Running Sheet").Activate
    Set RunningSheet = Worksheets("Running Sheet")
    Set BP_RunningSheet = Worksheets("BP - Running Sheet")
    
    CheckRow = 11   'Column "K" = column #11, if that changes, the letter
    InputArray = BP_RunningSheet.Range("A1:Z" & Range("A" & Rows.Count).End(xlUp).Row).Value
    ReDim OutputArray(1 To UBound(InputArray, 1), 1 To UBound(InputArray, 2))
    LastCol = UBound(InputArray, 2)
    CNT = 1
    
    For I = 1 To UBound(InputArray, 1)
        'Debug.Print InputArray(I, CheckRow)
        If InputArray(I, CheckRow) = "Yes" Then
            For N = 1 To 3  'B:D to A:C
                OutputArray(CNT, N) = InputArray(I, N + 1)
            Next N
            OutputArray(CNT, 4) = InputArray(I, 6) 'F to D
            OutputArray(CNT, 6) = InputArray(I, 9) 'I to F
            OutputArray(CNT, 7) = InputArray(I, 11) 'K to G
            OutputArray(CNT, 9) = InputArray(I, 14) 'N to I
            OutputArray(CNT, 10) = InputArray(I, 15) 'O to J
            OutputArray(CNT, 11) = InputArray(I, 16) 'P to K
            OutputArray(CNT, 13) = InputArray(I, 17) 'Q to M
            OutputArray(CNT, 8) = InputArray(I, 22) 'V to H
            CNT = CNT + 1
        End If
    Next I
    
    RunningSheet.Range("A1").Resize(UBound(OutputArray, 1), UBound(OutputArray, 2)).Value = OutputArray
    Worksheets("Running Sheet").Activate
    
End Sub

输入表“BP_RunningSheet”：

Output 表“RunningSheet”：

表架构：

PS：

我鼓励您为此尝试“=Filter(Array, Criteria)”function。 它的实现比 VBA 快得多。