Copying yellow cells in a range to another column on the same sheet with VBA

[paydog23]

I have a dataset that contains yellow cells (each yellow cell represents the final treatment plant or TP in a flow path) from Range("A2: F841"). Since the yellow cells are spread out randomly among the columns A to F, I would like to use VBA to copy them all as a single range in column J. I am doing this so that each well in column I has a corresponding final TP. Here's a screenshot of my spreadsheet

 

[DanteAmor]

If you put the color manually as a standard color, that is, it is not conditional formatting. Try the following:

Sub Copying_yellow_cells()
  Dim i As Long, j As Long
  For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
    For j = 1 To Columns("F").Column
      If Cells(i, j).Interior.Color = vbYellow Then
        Cells(i, "J").Value = Cells(i, j).Value
        Exit For
      End If
    Next
  Next
End Sub

 

[paydog23]

Wow, that worked perfectly! Thanks!

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.

 

[paydog23]

I'm glad to help you. Thanks for the feedback.

Thanks I actually just posted another related question--I had to manually color all those cells yellow but in the future I'd like to use VBA. I posted that question in this thread:

Conditionally format the last cell in each row with valuable data

I have a dataset for wells and 5 treatment plants (TP1, TP2, TP3, TP4, and TP5), which extends from A1 to F841. The flow path for each well is such that the well flows to TP1, then TP2, and so on. However, sometimes the flow path does not extend all the way to TP5. I have manually entered "None"...

www.mrexcel.com

 

[paydog23]

If you put the color manually as a standard color, that is, it is not conditional formatting. Try the following:

Sub Copying_yellow_cells()
  Dim i As Long, j As Long
  For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
    For j = 1 To Columns("F").Column
      If Cells(i, j).Interior.Color = vbYellow Then
        Cells(i, "J").Value = Cells(i, j).Value
        Exit For
      End If
    Next
  Next
End Sub

How would you copy the cells if you did use conditional formatting?

 

[Rick Rothstein]

If you put the color manually as a standard color, that is, it is not conditional formatting. Try the following:

Sub Copying_yellow_cells()
  Dim i As Long, j As Long
  For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
    For j = 1 To Columns("F").Column
      If Cells(i, j).Interior.Color = vbYellow Then
        Cells(i, "J").Value = Cells(i, j).Value
        Exit For
      End If
    Next
  Next
End Sub

I am not sure if the following will be faster (it will do less overall looping), but it is a alternative macro that will also work for manually colored cells...

Sub MoveYellowCellValuesToColumnJ()
  Dim Addr As String, Cell As Range
  Application.FindFormat.Clear
  Application.FindFormat.Interior.Color = vbYellow
  With Range("A1", Cells(Rows.Count, "F").End(xlUp))
    Set Cell = .Find("", SearchFormat:=True)
    If Not Cell Is Nothing Then
      Addr = Cell.Address
      Do
        Intersect(Cell.EntireRow, Columns("J")) = Cell.Value
        Set Cell = .Find("", Cell, SearchFormat:=True)
      Loop While Not Cell Is Nothing And Cell.Address <> Addr
    End If
  End With
  Application.FindFormat.Clear
End Sub

 

[paydog23]

I am not sure if the following will be faster (it will do less overall looping), but it is a alternative macro that will also work for manually colored cells...

Sub MoveYellowCellValuesToColumnJ()
  Dim Addr As String, Cell As Range
  Application.FindFormat.Clear
  Application.FindFormat.Interior.Color = vbYellow
  With Range("A1", Cells(Rows.Count, "F").End(xlUp))
    Set Cell = .Find("", SearchFormat:=True)
    If Not Cell Is Nothing Then
      Addr = Cell.Address
      Do
        Intersect(Cell.EntireRow, Columns("J")) = Cell.Value
        Set Cell = .Find("", Cell, SearchFormat:=True)
      Loop While Not Cell Is Nothing And Cell.Address <> Addr
    End If
  End With
  Application.FindFormat.Clear
End Sub

Thank you--do you what changes I'd need to make so that the macro works for conditionally formatted cells?

 

[DanteAmor]

Try this (not tested)

Sub Copying_yellow_cells()
  Dim i As Long, j As Long
  For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
    For j = 1 To Columns("F").Column
      If Cells(i, j).DisplayFormat.Interior.Color = vbYellow Then
        Cells(i, "J").Value = Cells(i, j).Value
        Exit For
      End If
    Next
  Next
End Sub

 

[Rick Rothstein]

How would you copy the cells if you did use conditional formatting?

Try this modification to Dante's code...

Sub Copying_yellow_cells()
  Dim i As Long, j As Long
  For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
    For j = 1 To Columns("F").Column
      If Cells(i, j).DisplayFormat.Interior.Color = vbYellow Then
        Cells(i, "J").Value = Cells(i, j).Value
        Exit For
      End If
    Next
  Next
End Sub