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

Question

I am new to VBA and I am trying to have a macro that will copy data from specific columns, should the row meet a certain criteria.

While the original document has more columns, the basic premise is that I have data entered into A through to F. If the value in F is Yes then I would like to copy data from column A, C & E to another sheet in A, B and C respectively.

I do not want the original data deleted but to stay on the page.

I have been using the below code which I tried to update from another code, but it was using UsedRange so I was trying to remove this and just use last row.

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

I find arrays nicer and faster to deal with:

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

Input Sheet "BP_RunningSheet":

Output Sheet "RunningSheet":

Sheet Architecture:

PS:

I would encourage you to try the "=Filter(Array, Criteria)" function for this. It is much faster to implement than VBA.