Macro extract data based on color background

[Jhon Mustofa]

hi all,

i am looking macro code to extract data from sheet1 to sheet2 & sheet3, with criteria background color :
1) extract data from sheet1 to sheet2 for data contains/highlighted yellow color background
2) extract data from sheet1 to sheet3 for data contains/highlighted red color background

for detail information, please see attached workbook..

any assistance would be greatly appreciated..

regards

john m

[nilem]

Hi John M,
try it

Sub ertert()
Dim i&, clr
Application.ScreenUpdating = False: i = 1
With Sheets("Sheet1").Range("A1").CurrentRegion
    .Parent.AutoFilterMode = False
    For Each clr In Array(vbYellow, vbRed)
        i = i + 1
        .AutoFilter Field:=2, Criteria1:=clr, Operator:=xlFilterCellColor
        .Offset(2).Copy Sheets("Sheet" & i).Range("A1")
    Next
    .AutoFilter
End With
Application.ScreenUpdating = True
End Sub

[Joakim N]

Try this code. I have attached in your workbook also.

ExtractColoredCells.xlsm

Sub ExtractData()
    Dim lRed As Long
    Dim lYellow As Long
    Dim rng As Range
    Dim wksData As Worksheet
    Dim wksYellow As Worksheet
    Dim wksRed As Worksheet
    
    Set wksData = Sheets("Sheet1")
    Set wksYellow = Sheets("Sheet2")
    Set wksRed = Sheets("Sheet3")
    
    'Clear sheets
    wksYellow.Cells.Delete
    wksRed.Cells.Delete

    'Copy rows to correct sheet
    For Each rng In Range(wksData.Range("B3"), wksData.Range("B3").End(xlDown))
        Select Case rng.Interior.Color
        Case RGB(255, 255, 0)
            lYellow = lYellow + 1
            rng.EntireRow.Copy wksYellow.Cells(lYellow, 1)
        Case RGB(255, 0, 0)
            lRed = lRed + 1
            rng.EntireRow.Copy wksRed.Cells(lRed, 1)
        End Select
    Next rng
    wksYellow.Range("A1").CurrentRegion.Columns.AutoFit
    wksRed.Range("A1").CurrentRegion.Columns.AutoFit
End Sub

[Jhon Mustofa]

hi Nilem & Joakim N, you are really great...

many thanks, i am helped...