I need a macro to copy cells based on fill color

[HaakLord]

Hi all,

I have a spreadsheet that I need to copy some specific data from and paste it to a new sheet. Column A has dates of events, column F has the expected number of attendants, column G has the actual number of attendants. There is a lot of other info that I don't need. The data I need is all in the same row and has a darker blue fill color. I would like a macro that would scrub the sheet finding all rows of that color and copy those rows to a new sheet.

I think that the fill color would be the best condition to use but if you think there is a better one please go for it. It could be finding a specific date format in column A then selecting that row to copy.

Here is an example of the data. Please let me know if you have any questions. If anyone can help it would be greatly appreciated!

Thank you!

 

[JoeMo]

I think that the fill color would be the best condition to use but if you think there is a better one please go for it. It could be finding a specific date format in column A then selecting that row to copy.

Here is an example of the data. Please let me know if you have any questions. If anyone can help it would be greatly appreciated!

Thank you!

Can you tell us the exact fill color or color index or RGB values you want to target?

 

[HaakLord]

Oops yeah that would be useful!

R:95, G:145, B:203

 

[JoeMo]

Lightly tested, but give this a try to see if it does what you want.

Sub HaakLord()
Dim R As Range, ws As Worksheet, c As Range, fAdr As String, Nx As Range
Set ws = ActiveSheet
With ws.Range("A:A")
    With Application
        .FindFormat.Clear
        .FindFormat.Interior.Color = RGB(95, 145, 203)
    End With
    Set R = .Cells.Find("", searchformat:=True)
    If Not R Is Nothing Then
        fAdr = R.Address
        Do
            If Nx Is Nothing Then
                Set Nx = .Cells.Find("", after:=R, searchformat:=True)
                If Nx Is Nothing Then Exit Do
                If Nx.Address = fAdr Then Exit Do
                Set R = Union(R, Nx)
            Else
                Set Nx = .Cells.Find("", after:=Nx, searchformat:=True)
                If Nx Is Nothing Then Exit Do
                If Nx.Address = fAdr Then Exit Do
                Set R = Union(R, Nx)
            End If
        Loop
    Else
        MsgBox "no dark-blue-filled cells in col A"
        Exit Sub
    End If
End With
Application.ScreenUpdating = False
On Error Resume Next
Application.DisplayAlerts = False
Sheets("New Sheet").Delete
On Error GoTo 0
Sheets.Add after:=ActiveSheet
With ActiveSheet
    .Name = "New Sheet"   'change name to suit
    .Range("A1:G1").Value = ws.Range("A1:G1").Value
End With
For Each c In R
    c.Resize(1, 7).Copy Sheets("New Sheet").Range("A" & Sheets("New Sheet").Cells(Rows.Count, "A").End(xlUp).Row + 1)
Next c
With Application
    .FindFormat.Clear
    .ScreenUpdating = True
    .CutCopyMode = False
End With
End Sub

 

[Rick Rothstein]

I believe this macro will also work...

[table="width: 500"]
[tr]
	[td]Sub HaakLord2()
  Dim R As Long, WS As Worksheet, ColA As Variant
  Set WS = ActiveSheet
  
  Application.ScreenUpdating = False
  On Error Resume Next
  Application.DisplayAlerts = False
  Sheets("New Sheet").Delete
  On Error GoTo 0
  Sheets.Add After:=ActiveSheet
  ActiveSheet.Name = "[B][COLOR="#FF0000"]New Sheet[/COLOR][/B]"
  
  WS.Rows(1).Copy Rows(1)
  ColA = WS.Range("A1", WS.Cells.Find("*", , xlValues, , xlRows, xlPrevious, , , False))
  For R = 2 To UBound(ColA)
    If Len(ColA(R, 1)) Then
      If WS.Cells(R, 1).Interior.Color = RGB(95, 145, 203) Then WS.Rows(R).Copy Cells(Rows.Count, "A").End(xlUp).Offset(1)
    End If
  Next
End Sub[/td]
[/tr]
[/table]

 

[HaakLord]

Lightly tested, but give this a try to see if it does what you want.

Sub HaakLord()
Dim R As Range, ws As Worksheet, c As Range, fAdr As String, Nx As Range
Set ws = ActiveSheet
With ws.Range("A:A")
    With Application
        .FindFormat.Clear
        .FindFormat.Interior.Color = RGB(95, 145, 203)
    End With
    Set R = .Cells.Find("", searchformat:=True)
    If Not R Is Nothing Then
        fAdr = R.Address
        Do
            If Nx Is Nothing Then
                Set Nx = .Cells.Find("", after:=R, searchformat:=True)
                If Nx Is Nothing Then Exit Do
                If Nx.Address = fAdr Then Exit Do
                Set R = Union(R, Nx)
            Else
                Set Nx = .Cells.Find("", after:=Nx, searchformat:=True)
                If Nx Is Nothing Then Exit Do
                If Nx.Address = fAdr Then Exit Do
                Set R = Union(R, Nx)
            End If
        Loop
    Else
        MsgBox "no dark-blue-filled cells in col A"
        Exit Sub
    End If
End With
Application.ScreenUpdating = False
On Error Resume Next
Application.DisplayAlerts = False
Sheets("New Sheet").Delete
On Error GoTo 0
Sheets.Add after:=ActiveSheet
With ActiveSheet
    .Name = "New Sheet"   'change name to suit
    .Range("A1:G1").Value = ws.Range("A1:G1").Value
End With
For Each c In R
    c.Resize(1, 7).Copy Sheets("New Sheet").Range("A" & Sheets("New Sheet").Cells(Rows.Count, "A").End(xlUp).Row + 1)
Next c
With Application
    .FindFormat.Clear
    .ScreenUpdating = True
    .CutCopyMode = False
End With
End Sub

That worked flawlessly! Thank you so much!

 

[JoeMo]

That worked flawlessly! Thank you so much!

You are welcome - thanks for the reply.

 

[Rick Rothstein]

That worked flawlessly! Thank you so much!

Just wondering... does that mean the code I posted in Message #5 did not work correctly for you. If it did not work correctly, could you please tell me in what way it did not work so I can try and figure out where I messed up?