Loop - Pasting data to the bottom of existing data

[larinda4]

I have part of my code below and it requires a little tweaking.

Breakdown: I have two worksheets, one called PivotTable and another called PerC. In my PivotTable worksheet, there is a value in Q2 that generally changes every month. I want it to go through column J and find any values that are greater than Q2. If it is greater than Q2, I want it to copy the value in column A and paste it into the PerC worksheet in cell G2. I want it to continue looking through column J and essentially create a list in the PerC worksheet column G.

Currently my code doesn't account for pasting it in the next cell under G2 and then continuing to do so for as many times as it needs to. It'll just continue to override G2.

Any help is appreciated!

Sub TestIDLabels()

Dim r As Range, filesheet As Worksheet, Rng As Range

Set filesheet = Sheets("PivotTable")

Set Rng = filesheet.Range("J3", filesheet.Range("J" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants, xlNumbers)

For Each r In Rng
    If r.Value > Range("Q2") Then 'This range is in the PivotTable worksheet
    ActiveCell.Offset(0, -9).Select
    ActiveCell.Copy
    Worksheets("PerC").Select
    Range("G2").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    End If
Next r


End Sub

 

[JEC]

Try this one

Sub jec()
 Dim it, a
 With Sheets("PivotTable")
   For Each it In .Range("J3", .Range("J" & Rows.Count).End(xlUp)).SpecialCells(2, 1)
     If it.Value > .Range("Q2") Then a = a & IIf(Len(a), "|", "") & it.Offset(, -9).Value
   Next
   Sheets("PerC").Range("G2").Resize(UBound(Split(a, "|")) + 1) = Application.Transpose(Split(a, "|"))
 End With
End Sub

or faster

Sub jecc()
 Dim ar, sq, i As Long, x as Long
 With Sheets("PivotTable")
    ar = .Range("A3", .Range("J" & Rows.Count).End(xlUp))
    ReDim sq(UBound(ar), 0)
     For i = 1 To UBound(ar)
       If ar(i, 10) > .Range("Q2") Then sq(x, 0) = ar(i, 1): x = x + 1
     Next
    Sheets("PerC").Range("G2").Resize(x) = sq
 End With
End Sub

 

[larinda4]

Try this one

Sub jec()
 Dim it, a
 With Sheets("PivotTable")
   For Each it In .Range("J3", .Range("J" & Rows.Count).End(xlUp)).SpecialCells(2, 1)
     If it.Value > .Range("Q2") Then a = a & IIf(Len(a), "|", "") & it.Offset(, -9).Value
   Next
   Sheets("PerC").Range("G2").Resize(UBound(Split(a, "|")) + 1) = Application.Transpose(Split(a, "|"))
 End With
End Sub

That was so fast and it worked like a charm. Thank you!!

 

[JEC]

You're welcome. Maybe the second code works too. That is completely array based.
Depends on how your data is located

 

[larinda4]

You're welcome. Maybe the second code works too. That is completely array based.
Depends on how your data is located

They both work amazing.

Thank you so much for your help.

 

[JEC]

Cheers