CODEWITHSUNDEEP
vbaloops
Jeremie Tomkins
Jeremie Tomkins

Reputation: 31

For loop while copy and pasting specific columns

I need a loop that will match and select different columns (not in sequential order) and paste them to another sheet all whilst keeping the condition in check. It would also be ideal if when the values get pasted that the formatting for the cell is not carried over, just the value.

Below is the code I am currently using:

Sub Test()
    Application.ScreenUpdating = False
    Sheets("DATA").Select
    lr = Range("B" & Rows.Count).End(xlUp).Row
    Range("P3").Select
    For i = 3 To lr
        If Cells(i, 2) <> "" Then Range(Cells(i, 7), Cells(i, 16), Cells(i, 26)).Copy 
        Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    Next
    Application.ScreenUpdating = True
End Sub

The problem is declaring the columns I want the loop to paste. I need the loop to run through the 16th column, check empty values, and then paste the index/matched value in the rows of columns 7,16,and 26 (so not in sequential order).. Any help would be appreciated.

The checkmarks on the right mean these values should be copied and pasted in columns A B C on the the other sheet. The X means since there were no values in in that row for the P column, the system must skip over copying these

Upvotes: 0

Views: 199

Answers (1)

FaneDuru
FaneDuru

Reputation: 42236

The next code has to do what I understood you need. Please check it and confirm this aspect. It is very fast, working only in memory... 

Sub PastingNextPage()
  Dim sh As Worksheet, sh1 As Worksheet, arrIn As Variant, arrOut() As Variant
  Dim lastRowIn As Long, lastRowOut As Long, nonEmpt As Long, rngP As Range, nrEl As Long
  Dim i As Long, j As Long, P As Long

  Set sh = Sheets("DATA"): lastRowIn = sh.Range("P" & sh.Rows.count).End(xlUp).Row
  Set sh1 = Sheets("Sheet2"): lastRowOut = sh1.Range("A" & sh1.Rows.count).End(xlUp).Row + 1

  arrIn = sh.Range("G2:Z" & lastRowIn).Value

  nrEl = lastRowIn - Application.WorksheetFunction.CountIf(sh.Range("P2:P" & lastRowIn), "") - 2
    P = 10 'column P:P number in the range starting with G:G column
    ReDim arrOut(nrEl, 3) 'redim the array to keep the collected values
    For i = 1 To lastRowIn - 1
        If arrIn(i, P) <> "" Then
            arrOut(j, 0) = arrIn(i, 1): arrOut(j, 1) = arrIn(i, P): arrOut(j, 2) = arrIn(i, 20)
            j = j + 1
        End If
    Next i

    sh1.Range(sh1.Cells(lastRowOut, "A"), sh1.Cells(lastRowOut + nrEl, "C")).Value = arrOut
End Sub

It does not select anything, you can run it activating any of the two involved sheets. I would recommend to be in "Sheet2" and see the result. If you want to repeat the test, its result will be added after the previous testing resulted rows...

If something unclear or not doing what you need, do not hesitate to ask for clarifications.

Upvotes: 1

Related Questions