Loop through Auto Filter Criteria and Copy Formula Results Into New Sheet

Hi hamidxa

Replace the Code with this

Option Explicit

Sub Filter_Stuff()
  Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
  Dim LR As Long, LC As Long
  Dim cel As Range, Rng As Range

  Application.ScreenUpdating = False
  If Not Evaluate("ISREF(Lists!A1)") Then
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Lists"
  Else
    Sheets("Lists").Cells.Clear
  End If

  Set ws = Sheets("FW15")
  Set ws1 = Sheets("Lists")
  Set ws2 = Sheets("CopiedResults")

  With ws2
    .UsedRange.Offset(1, 0).Clear
  End With

  With ws
    LC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                     SearchDirection:=xlPrevious).Column
    LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                     SearchDirection:=xlPrevious).Row
    .Range("A3:A" & LR).AdvancedFilter Action:=xlFilterCopy, _
                                       CopyToRange:=ws1.Range("A1"), Unique:=True
    ActiveWorkbook.Names.Add Name:="AAA", RefersTo:= _
                             "=OFFSET(Lists!$A$2,0,0,(COUNTA(Lists!$A:$A)-1),1)"
    ws1.Range("AAA").Sort Key1:=ws1.Range("A2"), Order1:=xlAscending, _
                          Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    ws1.Range("AAA").Copy ws2.Range("A2")

    .Range("B3:B" & LR).AdvancedFilter Action:=xlFilterCopy, _
                                       CopyToRange:=ws1.Range("B1"), Unique:=True
    ActiveWorkbook.Names.Add Name:="BBB", RefersTo:= _
                             "=OFFSET(Lists!$B$2,0,0,(COUNTA(Lists!$B:$B)-1),1)"
    ws1.Range("BBB").Sort Key1:=ws1.Range("B2"), Order1:=xlAscending, _
                          Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    ws1.Range("BBB").Copy ws2.Range("C2")

    .Range("C3:C" & LR).AdvancedFilter Action:=xlFilterCopy, _
                                       CopyToRange:=ws1.Range("C1"), Unique:=True
    ActiveWorkbook.Names.Add Name:="CCC", RefersTo:= _
                             "=OFFSET(Lists!$C$2,0,0,(COUNTA(Lists!$C:$C)-1),1)"
    ws1.Range("CCC").Sort Key1:=ws1.Range("C2"), Order1:=xlAscending, _
                          Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    ws1.Range("CCC").Copy ws2.Range("E2")

    If Not .AutoFilterMode Then
      .Rows("3:3").AutoFilter
    End If

    Set Rng = ws2.Range(("A2"), ws2.Range("A2").End(xlDown))

    For Each cel In Rng
      .Range(.Cells(3, 1), .Cells(LR, LC)).AutoFilter field:=1, Criteria1:=cel.Value
      .Range(.Cells(3, 1), .Cells(LR, LC)).AutoFilter field:=9, Criteria1:="Compliant"
      ws2.Range(cel.Address).Offset(0, 1).Value = .Range("F2").Text
    Next cel
    .AutoFilterMode = False

    Set Rng = ws2.Range(("C2"), ws2.Range("C2").End(xlDown))

    For Each cel In Rng
      .Range(.Cells(3, 1), .Cells(LR, LC)).AutoFilter field:=2, Criteria1:=cel.Value
      .Range(.Cells(3, 1), .Cells(LR, LC)).AutoFilter field:=9, Criteria1:="Compliant"
      ws2.Range(cel.Address).Offset(0, 1).Value = .Range("F2").Text
    Next cel
    .AutoFilterMode = False

    Set Rng = ws2.Range(("E2"), ws2.Range("E2").End(xlDown))
    For Each cel In Rng
      .Range(.Cells(3, 1), .Cells(LR, LC)).AutoFilter field:=3, Criteria1:=cel.Value
      .Range(.Cells(3, 1), .Cells(LR, LC)).AutoFilter field:=9, Criteria1:="Compliant"
      ws2.Range(cel.Address).Offset(0, 1).Value = .Range("F2").Text
    Next cel
    .AutoFilterMode = False

  End With
  Application.DisplayAlerts = False
  Sheets("Lists").Delete
  Application.DisplayAlerts = True
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
End Sub

You're welcome...glad I could help. Thanks for the Rep.

If this resolves your issue please mark your Thread as SOLVED.

New quick method:
Select Thread Tools-> Mark thread as Solved. To undo, select Thread Tools-> Mark thread as Unsolved.

Or you can use this way:
How to mark a thread Solved
Go to the first post
Click edit
Click Go Advanced
Just below the word Title you will see a dropdown with the word No prefix.
Change to Solved
Click SaveYou're welcome...glad I could help.