Loop through Auto Filter Criteria and Copy Cell Results Into Another Sheet

[hamidxa]

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.

 

[Redwolfx]

This is untested and there may be a better way,

Try:

Sub Macro1()
Dim mycell As Range
Dim LastRow As Long
Dim Lastrow2 As Long
Dim WS As Worksheet
Dim Cat As String
Dim WSCount As Long
Dim NR As Long
Application.ScreenUpdating = False
WSCount = Worksheets.Count
NR = Sheets("CopiedResults").Range("C1000000").End(xlUp).Row + 1
LastRow = Sheets(1).Range("C1000000").End(xlUp).Row
    For Each mycell In Sheets(1).Range("C2:C" & LastRow)
        Checksheet mycell.Value
    Next mycell
    For Each WS In ThisWorkbook.Worksheets
        If WS.Index > WSCount Then
            Cat = WS.Name
            
           For Each mycell In Sheets(1).Range("C2:C" & LastRow)
                If mycell.Value <> Cat Then
                    mycell.EntireRow.Hidden = True
                End If
            Next mycell
           
            Sheets(1).Range("A1:Z" & LastRow).SpecialCells(xlCellTypeVisible).Copy
            WS.Cells.PasteSpecial xlPasteValuesAndNumberFormats
            WS.Range("F2").Copy Sheets("CopiedResults").Range("C" & NR)
            NR = NR + 1
        End If
        Sheets(1).Rows("1:" & LastRow).Hidden = False
    Next WS
    
Application.DisplayAlerts = False
    
  For Each WS In ThisWorkbook.Worksheets
        If WS.Index > WSCount Then
            WS.Delete
        End If
  Next WS
Application.DisplayAlerts = True
'_______________________________________________________________________
NR = Sheets("CopiedResults").Range("A1000000").End(xlUp).Row + 1
LastRow = Sheets(1).Range("A1000000").End(xlUp).Row
    For Each mycell In Sheets(1).Range("A2:A" & LastRow)
        Checksheet mycell.Value
    Next mycell
    For Each WS In ThisWorkbook.Worksheets
        If WS.Index > WSCount Then
            Cat = WS.Name
            
           For Each mycell In Sheets(1).Range("A2:A" & LastRow)
                If mycell.Value <> Cat Then
                    mycell.EntireRow.Hidden = True
                End If
            Next mycell
           
            Sheets(1).Range("A1:Z" & LastRow).SpecialCells(xlCellTypeVisible).Copy
            WS.Cells.PasteSpecial xlPasteValuesAndNumberFormats
            WS.Range("F2").Copy Sheets("CopiedResults").Range("A" & NR)
            NR = NR + 1
        End If
        Sheets(1).Rows("1:" & LastRow).Hidden = False
    Next WS
    
Application.DisplayAlerts = False
    
  For Each WS In ThisWorkbook.Worksheets
        If WS.Index > WSCount Then
            WS.Delete
        End If
  Next WS
Application.DisplayAlerts = True
'_______________________________________________________________________
NR = Sheets("CopiedResults").Range("B1000000").End(xlUp).Row + 1
LastRow = Sheets(1).Range("B1000000").End(xlUp).Row
    For Each mycell In Sheets(1).Range("B2:B" & LastRow)
        Checksheet mycell.Value
    Next mycell
    For Each WS In ThisWorkbook.Worksheets
        If WS.Index > WSCount Then
            Cat = WS.Name
            
           For Each mycell In Sheets(1).Range("B2:B" & LastRow)
                If mycell.Value <> Cat Then
                    mycell.EntireRow.Hidden = True
                End If
            Next mycell
           
            Sheets(1).Range("A1:Z" & LastRow).SpecialCells(xlCellTypeVisible).Copy
            WS.Cells.PasteSpecial xlPasteValuesAndNumberFormats
            WS.Range("F2").Copy Sheets("CopiedResults").Range("B" & NR)
            NR = NR + 1
        End If
        Sheets(1).Rows("1:" & LastRow).Hidden = False
    Next WS
    
Application.DisplayAlerts = False
    
  For Each WS In ThisWorkbook.Worksheets
        If WS.Index > WSCount Then
            WS.Delete
        End If
  Next WS
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub Checksheet(mycell As String)
Dim WSto As Worksheet
On Error Resume Next
    'Sets WSto for ongoing use
    Set WSto = Sheets(mycell)
    If Err <> 0 Then
        Err.Clear
        Set WSto = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        WSto.Name = mycell
        If Err <> 0 Then
            GoTo Errhandler
        End If
    End If
On Error GoTo 0
Errhandler:
End Sub

 

[hamidxa]

Redwolf,

Thank you for the post.
I ran the code you provided against my workbook, but it did not produce the results that I had hoped.
Rather, it created new sheets named after each of the criteria in Col C, and copied over the filtered criteria relative to that sheet.

So for instance, Col C had district numbers such as:
206 (with 17 rows of values)
323 (with 14 rows of values)
341 (with 20 rows of values)
etc.
etc.
And this code generated sheets named 206, 323, 341, etc. with all of the different rows relative to those districts from the main FW15 sheet.
However, it did not copy the F2 values.

Per the original requirement, I was also interested in seeing if there would be a way to just copy the F2 values onto a single sheet with respect to the column criteria that is filtered, rather than generate new sheets.

All in all, a helpful first attempt and a learning experience, which is greatly appreciated!

However, still stumped, and this is honestly beyond my feeble attempts to manipulate the code you provided as well.

 

[hamidxa]

Sorry, wasnt aware of the attachment limitation/restriction.
Here's a link to the file:
https://drive.google.com/file/d/0B-ICIDa_WsS2RGJnVXJfMURvVTA/edit?usp=sharing

 

[hamidxa]

Apologies for the bump, but just want to add even more clarity.

Here is a snapshot of what I am envisioning the results page looking like:
https://app.box.com/s/m8xz3cvbf14sl4qigrkg

So essentially, if I filter against each of the criteria in Cols A, B, or C, to copy their corresponding cell F2 values for each criteria into say Sheet2.

 

[Redwolfx]

Did you run my code all the way through?

The code works as you describe, but then it should be copying Cell F2 from the sheets to CopiedResults, then deleting the sheets. Unfortunately I can not open your links where I'm at.

This worked on my test file. I'm not sure why it wouldn't work for you.

 

[hamidxa]

I will rerun and report back.

 

[hamidxa]

Redwolf.
I let it run all the way through this time, but it did not produce the results I expected, as per the linked image on post #5.

Not sure if its something Im not doing right, but I've tried it twice now.

 

[Redwolfx]

The link sends me to a page that says I've reached this page in error