copy over specific colored cells to another sheet

[scubadivingfool]

I am using the following code to copy rows from on sheet and make them columns onto another sheet. The code copies every row in the specific sheet however I just need the ones colored in red.

Sub PrintToLargeTags()
   Dim pc As Worksheet 'PriceChange
   Dim lt As Worksheet 'LargeTags
   Dim count_col As Integer
   Dim count_row As Integer
   Dim i As Integer
   Dim j As Integer
   
   
   Set pc = ThisWorkbook.Sheets("PriceChange")
   Set lt = ThisWorkbook.Sheets("LargeTags")
   
   lt.Cells.ClearContents
   pc.Activate
   
   count_col = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlToRight)))
   count_row = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))
   
   For i = 1 To count_col
      For j = 1 To count_row
         lt.Cells(i, j) = pc.Cells(j, i).Text
      
      Next j
   Next i
   
   lt.Activate
   
   
End Sub

 

[Zot]

Perhaps something like this. This check if the pc.Cells(j, i) cell color is red (ColorIndex = 3) and copy. Is that what you wanted?

Sub PrintToLargeTags()
   Dim pc As Worksheet 'PriceChange
   Dim lt As Worksheet 'LargeTags
   Dim count_col As Integer
   Dim count_row As Integer
   Dim i As Integer
   Dim j As Integer
   
   
   Set pc = ThisWorkbook.Sheets("PriceChange")
   Set lt = ThisWorkbook.Sheets("LargeTags")
   
   lt.Cells.ClearContents
   pc.Activate
   
   count_col = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlToRight)))
   count_row = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))
   
   For i = 1 To count_col
      For j = 1 To count_row
        If pc.Cells(j, i).Interior.ColorIndex = 3 Then
            lt.Cells(i, j) = pc.Cells(j, i).Text
        End If
      Next j
   Next i
   
   lt.Activate
   
   
End Sub

 

[scubadivingfool]

Perhaps something like this. This check if the pc.Cells(j, i) cell color is red (ColorIndex = 3) and copy. Is that what you wanted?

Sub PrintToLargeTags()
   Dim pc As Worksheet 'PriceChange
   Dim lt As Worksheet 'LargeTags
   Dim count_col As Integer
   Dim count_row As Integer
   Dim i As Integer
   Dim j As Integer
  
  
   Set pc = ThisWorkbook.Sheets("PriceChange")
   Set lt = ThisWorkbook.Sheets("LargeTags")
  
   lt.Cells.ClearContents
   pc.Activate
  
   count_col = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlToRight)))
   count_row = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))
  
   For i = 1 To count_col
      For j = 1 To count_row
        If pc.Cells(j, i).Interior.ColorIndex = 3 Then
            lt.Cells(i, j) = pc.Cells(j, i).Text
        End If
      Next j
   Next i
  
   lt.Activate
  
  
End Sub

OK, almost worked. The only cells that I need on that page do show up but as shown in the image below it doesn't start at A1

 

[Zot]

I was just adding line to your original code. I have no idea what is your lookup range. Maybe you can show your pc and lt sheet?