Macro to extract Rows Colored with Yellow Fill and create a new sheet as per current month

Hello All,

I am using Excel 2010 and have the following problem.

I have a macro which looks up Value in Col C and compare it with Col B and color the value with yellow background color (See Account Sheet sample attached)

I want a macro which should copy all the yellow colored Cells from Account sheet together with Col A C D F H I K showing only the current month Column shown in Row 1.
Eg if the macro is run in the month of Aug the macro should create a new sheet named Aug

In September the new sheet would be Sept and so on and so forth

See the result on sheet for Aug required

A new macro or a modified version of my macro would help

Thanks in advance
Rashid Khan

Try:

Sub foo()
    Dim wsSrc As Worksheet
    Dim wsTgt As Worksheet
    Dim arrCopy() As Variant
    Dim i As Integer
    Dim iMonth As String
    Dim sMonth As String
    
    On Error GoTo Terminate
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
        
    Set wsSrc = Worksheets("Account")
    arrCopy = Array("A", "B", "D", "F", "H", "I", "K")
    
    iMonth = Month(Date)
    sMonth = Format(Date, "MMM")
    
    If SheetExists(sMonth) Then Worksheets(sMonth).Delete
    Set wsTgt = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    wsTgt.Name = sMonth
    
    With wsSrc
        .AutoFilterMode = False
        .UsedRange.AutoFilter field:=2, Criteria1:=RGB(255, 255, 0), Operator:=xlFilterCellColor
        For i = LBound(arrCopy) To UBound(arrCopy)
            .UsedRange.Columns(arrCopy(i)).SpecialCells(xlCellTypeVisible).Copy wsTgt.Cells(1, i + 1)
        Next i
        .UsedRange.Columns(11 + iMonth).SpecialCells(xlCellTypeVisible).Copy wsTgt.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
        .AutoFilterMode = False
    End With
    
Terminate:
    If Err Then
        Debug.Print "ERROR", Err.Number, Err.Description
        Err.Clear
    End If
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub

Function SheetExists(ByVal sSheetName As String) As Boolean
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If UCase(ws.Name) = UCase(sSheetName) Then
            SheetExists = True
            Exit Function
        End If
    Next ws
End Function

Happy to help. Don't forget to click 'Add Reputation' as well!