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
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":
PS:
I would encourage you to try the "=Filter(Array, Criteria)" function for this. It is much faster to implement than VBA.
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.