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

I have a worksheet that contains 3 columns, A, B, C, that I need to run through auto-filter and copy the results from a cell, F2, into another sheet each time the filter criteria changes.


As an example, here is how I would envision this working for Col C:
1. Starting on the 1st Sheet (named "FW15"), I auto-filter Col C on criteria/value 1
2. I copy the resulting value from Cell F2 of sheet FW15 and paste it into the first empty cell of Col C in Sheet 2 (named "CopiedResults")
3. I return to my first sheet, FW15, turn off the enabled filter for criteria/value (1), and turn on the next autofilter Criteria/Value (of 2)
4. Repeat Step 2
.
.
Keep looping through Autofilter criteria in Col C, and copy each resulting value contained in Cell F2 over to the second sheet.

Likewise, I would need to run through the auto-filter criteria in Col A and Col B, and copy their resulting values (from cell F2) into Sheet2 Col A and Col B.

Really stuck on how to loop and copy the resulting values, and would greatly appreciate some help on this.

Hi hamidxa

This is my perception of what you're looking for

Option Explicit

Sub Filter_Stuff()
  Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
  Dim LR As Long, LR2 As Long
  Dim cel 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).ClearContents
    LR2 = 2
  End With

  With ws
    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

    .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

    .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

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

    For Each cel In Range("AAA")
      .Range("A3:A" & LR).AutoFilter field:=1, Criteria1:=cel.Value
      .Range("F2:F" & LR).SpecialCells(xlCellTypeVisible).Copy
      ws2.Range("A" & LR2).PasteSpecial (xlPasteValues)
      LR2 = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
    Next cel
    .AutoFilterMode = False

    LR2 = 2
    For Each cel In Range("BBB")
      .Range("B3:B" & LR).AutoFilter field:=1, Criteria1:=cel.Value
      .Range("F2:F" & LR).SpecialCells(xlCellTypeVisible).Copy
      ws2.Range("B" & LR2).PasteSpecial (xlPasteValues)
      LR2 = ws2.Range("B" & Rows.Count).End(xlUp).Row + 1
    Next cel
    .AutoFilterMode = False

    LR2 = 2
    For Each cel In Range("CCC")
      .Range("C3:C" & LR).AutoFilter field:=1, Criteria1:=cel.Value
      .Range("F2:F" & LR).SpecialCells(xlCellTypeVisible).Copy
      ws2.Range("C" & LR2).PasteSpecial (xlPasteValues)
      LR2 = ws2.Range("C" & Rows.Count).End(xlUp).Row + 1
    Next cel
    .AutoFilterMode = False

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

Hi hamidxa

I see...the results I was getting made no sense to me.

Let me take another stab at it...get back to you...

Do you want the Results Sheet to look like the Image you posted?

Hi hamidxa

See if this works better for you...

Option Explicit

Sub Filter_Stuff()
  Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
  Dim LR 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
    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("A3:A" & LR).AutoFilter field:=1, Criteria1:=cel.Value
      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("B3:B" & LR).AutoFilter field:=1, Criteria1:=cel.Value
      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("C3:C" & LR).AutoFilter field:=1, Criteria1:=cel.Value
      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

jaslake,

Woah, that's brilliant!

I hate to almost ask this, but what if I wanted to enable the filter in Column I to always read "Compliant" as its criteria through each iteration of these loops.