VBA to copy cell data with conditional formatting and paste data elsewhere

[Darren_workforce]

I've looked online and am struggling to find what I need.

Column A is just a list of names. Some of those names have been shaded yellow through a CF macro (it does other things as well). What I was hoping to do was have the names highlighted yellow copied and then pasted into B2:Bxx (preferably in alphabetical order). Is that something that can be done?

 

[Joe4]

What is the Conditional Formatting rule to turn the cells yellow?
You may be able to use that same rule in a new FILTER function to return those records.

 

[Darren_workforce]

What is the Conditional Formatting rule to turn the cells yellow?
You may be able to use that same rule in a new FILTER function to return those records.

Range("A2:A120").Select
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=(COUNTIF('9-45 meeting'!$A$1:$A$150,$A2)+COUNTIF('9-15 meeting'!$A$1:$A$150,$A2)+COUNTIF('10-15 meeting'!$A$1:$A$150,$A2))=0"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False

This is just a part of the VBA. I scan 3 tabs and if the names in Column A do not appear in any of those tabs, the CF shades the cell.

 

[Joe4]

Try this code then:

Sub MyCopyYellowCells()

    Dim lrA As Long
    Dim rA As Long
    Dim rB As Long
    Dim rngB As Range
    
    Application.ScreenUpdating = False
    
'   Find last row in column A with data
    lrA = Cells(Rows.Count, "A").End(xlUp).Row
    
'   Initialize column B row counter
    rB = 1
    
'   Loop through all cells in column A, starting at row 2
    For rA = 2 To lrA
'       Check to see if color of cell in yellow
        If Cells(rA, "A").DisplayFormat.Interior.Color = 65535 Then
'           Add one to column B row counter
            rB = rB + 1
'           Copy value to column B
            Cells(rB, "B").Value = Cells(rA, "A").Value
        End If
    Next rA
    
'   Set column B range to sort
    Set rngB = Range("B2:B" & rB)
    
'   Sort column B
    ActiveSheet.Sort.SortFields.Add2 Key:=rngB _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange rngB
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    Application.ScreenUpdating = True
        
End Sub

Here is my test showing it working:

 

[Darren_workforce]

Try this code then:

Sub MyCopyYellowCells()

    Dim lrA As Long
    Dim rA As Long
    Dim rB As Long
    Dim rngB As Range
   
    Application.ScreenUpdating = False
   
'   Find last row in column A with data
    lrA = Cells(Rows.Count, "A").End(xlUp).Row
   
'   Initialize column B row counter
    rB = 1
   
'   Loop through all cells in column A, starting at row 2
    For rA = 2 To lrA
'       Check to see if color of cell in yellow
        If Cells(rA, "A").DisplayFormat.Interior.Color = 65535 Then
'           Add one to column B row counter
            rB = rB + 1
'           Copy value to column B
            Cells(rB, "B").Value = Cells(rA, "A").Value
        End If
    Next rA
   
'   Set column B range to sort
    Set rngB = Range("B2:B" & rB)
   
'   Sort column B
    ActiveSheet.Sort.SortFields.Add2 Key:=rngB _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange rngB
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   
    Application.ScreenUpdating = True
       
End Sub

Here is my test showing it working:
View attachment 121987

That's fantastic!! That did exactly what I was looking for THANK YOU!

One small item though. The list of names is generated from another worksheet. Since I never know how many names there will be, I pull a generic range of cells which means there are always a few zeroes at the bottom of the name list. Because of this, your code grabs those zeroes into column B along with the names. Can those be ignored when copying/pasting?

 

[Darren_workforce]

That's fantastic!! That did exactly what I was looking for THANK YOU!

One small item though. The list of names is generated from another worksheet. Since I never know how many names there will be, I pull a generic range of cells which means there are always a few zeroes at the bottom of the name list. Because of this, your code grabs those zeroes into column B along with the names. Can those be ignored when copying/pasting?

I actually added code to remove the zeroes since previously I never had to worry about them. Since I deleted them, your code pulled exactly what I'm looking for. Appreciate your assistance again!!

 

[Joe4]

As long as those zeroes are not being colored yellow, they should not be being copied over to column B.
However, it sounds like maybe they are.

If that is the case, you can change this line:

        If Cells(rA, "A").DisplayFormat.Interior.Color = 65535 Then

to this to not copy them to column B

        If (Cells(rA, "A").DisplayFormat.Interior.Color = 65535) and (Cell(rA ,"A").Value <> 0) Then

 

[Joe4]

I actually added code to remove the zeroes since previously I never had to worry about them. Since I deleted them, your code pulled exactly what I'm looking for. Appreciate your assistance again!!

You are welcome.
Glad I was able to help!