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

paydog23

New Member
Joined
Jul 12, 2017
Messages
23
Office Version
365
Platform
Windows
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

YellowCells.jpg
 

Some videos you may like

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
10,211
Office Version
2007
Platform
Windows
If you put the color manually as a standard color, that is, it is not conditional formatting. Try the following:

VBA 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).Interior.Color = vbYellow Then
        Cells(i, "J").Value = Cells(i, j).Value
        Exit For
      End If
    Next
  Next
End Sub
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
10,211
Office Version
2007
Platform
Windows
I'm glad to help you. Thanks for the feedback.
 

paydog23

New Member
Joined
Jul 12, 2017
Messages
23
Office Version
365
Platform
Windows
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:

 

paydog23

New Member
Joined
Jul 12, 2017
Messages
23
Office Version
365
Platform
Windows
If you put the color manually as a standard color, that is, it is not conditional formatting. Try the following:

VBA 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).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

MrExcel MVP
Joined
Apr 18, 2011
Messages
35,654
Office Version
2010
Platform
Windows
If you put the color manually as a standard color, that is, it is not conditional formatting. Try the following:

VBA 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).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...
VBA Code:
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

New Member
Joined
Jul 12, 2017
Messages
23
Office Version
365
Platform
Windows
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...
VBA Code:
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

Well-known Member
Joined
Dec 3, 2018
Messages
10,211
Office Version
2007
Platform
Windows
Try this (not tested)

VBA 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
 

Rick Rothstein

MrExcel MVP
Joined
Apr 18, 2011
Messages
35,654
Office Version
2010
Platform
Windows
How would you copy the cells if you did use conditional formatting?
Try this modification to Dante's code...
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
 

Forum statistics

Threads
1,089,689
Messages
5,409,805
Members
403,279
Latest member
ricardovobarros

This Week's Hot Topics

Top