loop through autofilter drop down

jacknc · Nov 30, 2005

I currently have a macro that i run after first selecting a state from autofilter list. I would like to create a loop that takes first line AFTER custom... on autofilter list and runs macro. Then goes to next item in autofilter list. Currently the 'dropdown' is located on sheet 4 a1

Any help would be greatly appreciated.

Thanks,
Jack

Von Pookie · Nov 30, 2005

I did something like that here:
http://www.mrexcel.com/board2/viewtopic.php?t=177857

I believe you should be able to edit it to your specific needs. Post back if you need help with it

jacknc · Nov 30, 2005

Kristy,

I believe that is exactly what I need. Actually very similar excel sheet. He was wanting criteria based on column 2 - town. I need it to be based on column 1 - state w/ header - sheet4(a1). I tried adjusting the column and variable. Closest I got was a single run (my code creates a single text file.) Whereas I was hoping to have 50.

can you tell me where I need to place my code.

Sub Export()
Dim Textfile As Variant
Dim LastRow As Long
Dim XportArea As Range
Dim Cel As Range
Dim i As Long
Dim iCol As Long
Dim iRow As Long
Dim iFnum As Integer

Sheets("Sheet4").Activate
Columns("A:B").Select
Selection.specialcells(xlCellTypeVisible).Select
Selection.copy
Sheets("Sheet1").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Path = "c:\t\"
Sheets("Sheet1").Activate
Textfile = Range("A2").Value
Filename = LCase(Replace(Textfile, " ", ""))
savefile = Path & Filename & ".txt"
'Select a textfile to save to
'Textfile = Application.GetSaveAsFilename( _
' InitialFileName:="text.txt", _
'FileFilter:="Text files, *.txt)", _
' Title:="Save textfile as:")
If Textfile = False Then Exit Sub
On Error Resume Next
'open / create the textfile
iFnum = FreeFile
Open CStr(savefile) For Append As iFnum
'Select the cells to export:
Sheets("Sheet6").Activate
Set XportArea = Sheets("sheet6").Range([A1], [A65536].End(xlUp))
For iCol = 1 To XportArea.Columns.Count
For iRow = 1 To XportArea.Rows.Count
If XportArea.Cells(iRow, iCol).Text <> "" Then

Print #iFnum, XportArea.Cells(iRow, iCol).Text
End If
Next iRow
Next iCol

Sheets("menu").Activate
Set XportArea = Sheets("menu").Range([A1], [A65536].End(xlUp))
For iCol = 1 To XportArea.Columns.Count
For iRow = 1 To XportArea.Rows.Count
If XportArea.Cells(iRow, iCol).Text <> "" Then
Print #iFnum, XportArea.Cells(iRow, iCol).Text
End If
Next iRow
Next iCol

Sheets("Sheet1").Activate
' Get number of columns value from sheet 1
i = Sheets("Sheet1").Range("C2").Value
Sheets("table").Activate
Set XportArea = Sheets("table").Range("B1").Resize(5, i)
For iCol = 1 To XportArea.Columns.Count
For iRow = 1 To XportArea.Rows.Count
If XportArea.Cells(iRow, iCol).Text <> "" Then
Print #iFnum, XportArea.Cells(iRow, iCol).Text
End If
Next iRow
Next iCol

Sheets("end").Activate
Set XportArea = Sheets("end").Range([A1], [A65536].End(xlUp))
For iCol = 1 To XportArea.Columns.Count
For iRow = 1 To XportArea.Rows.Count
If XportArea.Cells(iRow, iCol).Text <> "" Then
Debug.Print XportArea.Cells(iRow, iCol).Text
Print #iFnum, XportArea.Cells(iRow, iCol).Text

End If
Next iRow
Next iCol
Close #iFnum

Sheets("Sheet4").Activate
End Sub

Von Pookie · Nov 30, 2005

So you're wanting to run the Export code 1 time for each unique item listed in the autofilter?

You probably need to make some changes to both my macro and your Export macro (at this exact second I don't have the time to play with it), but I believe you should simply be able to call your Export macro from within the Autofilter macro.

Code:

'loop through Criteria
    For x = LBound(Criteria) To UBound(Criteria)
        'filter "Town" column using criteria
        .AutoFilter field:=2, Criteria1:=Criteria(x)
   
        '***instead of this portion of code, try replacing it with a call to your Export macro
        With myRng.SpecialCells(xlCellTypeVisible)
            'run code on visible cells within myRng
        End With
       '**********
    Next x 'display filter results for next item

jacknc · Nov 30, 2005

Kristy,

I believe I figure out part of the problem. For some reason the loop is NOT splitting. It is using ALL records(3146) instead of 50 (states).
Here is code I have so far.

Code:

Sub Export(Criteria)
Dim Textfile As Variant
Dim LastRow As Long
Dim XportArea As Range
Dim Cel As Range
Dim i As Long
Dim iCol As Long
Dim iRow As Long
Dim iFnum As Integer
Sheets("Sheet3").Activate
 Columns("A:B").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Sheet1").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Path = "C:\Documents and Settings\jack\Desktop\"
Sheets("Sheet1").Activate
Textfile = Range("A2").Value
Filename = LCase(Replace(Textfile, " ", ""))
savefile = Path & Filename & ".txt"
'Select a textfile to save to
'Textfile = Application.GetSaveAsFilename( _
 ' InitialFileName:="text.txt", _
'FileFilter:="Text files, *.txt)", _
 ' Title:="Save textfile as:")
If Textfile = False Then Exit Sub
On Error Resume Next
'open / create the textfile
iFnum = FreeFile
Open CStr(savefile) For Append As iFnum
'Select the cells to export:
Sheets("Output#1").Activate
Set XportArea = Sheets("Output#1").Range([A1], [A65536].End(xlUp))
For iCol = 1 To XportArea.Columns.Count
For iRow = 1 To XportArea.Rows.Count
If XportArea.Cells(iRow, iCol).Text <> "" Then

 Print #iFnum, XportArea.Cells(iRow, iCol).Text
 Debug.Print XportArea.Cells(iRow, iCol).Text
 End If
Next iRow
Next iCol

Sheets("Output#2").Activate
Set XportArea = Sheets("Output#2").Range([A1], [A65536].End(xlUp))
For iCol = 1 To XportArea.Columns.Count
For iRow = 1 To XportArea.Rows.Count
If XportArea.Cells(iRow, iCol).Text <> "" Then
 Print #iFnum, XportArea.Cells(iRow, iCol).Text
 End If
Next iRow
Next iCol

Sheets("Output#3").Activate
Set XportArea = Sheets("Output#3").Range([A1], [A65536].End(xlUp))
For iCol = 1 To XportArea.Columns.Count
For iRow = 1 To XportArea.Rows.Count
If XportArea.Cells(iRow, iCol).Text <> "" Then
 Print #iFnum, XportArea.Cells(iRow, iCol).Text
 End If
Next iRow
Next iCol


Sheets("Sheet1").Activate
' Get number of columns value from sheet 1
i = Sheets("Sheet1").Range("C2").Value
Sheets("Output#4").Activate
Set XportArea = Sheets("Output#4").Range("B1").Resize(5, i)
For iCol = 1 To XportArea.Columns.Count
For iRow = 1 To XportArea.Rows.Count
If XportArea.Cells(iRow, iCol).Text <> "" Then
Debug.Print XportArea.Cells(iRow, iCol).Text
 Print #iFnum, XportArea.Cells(iRow, iCol).Text
End If
Next iRow
Next iCol

Sheets("Output#5").Activate
Set XportArea = Sheets("Output#5").Range([A1], [A65536].End(xlUp))
For iCol = 1 To XportArea.Columns.Count
For iRow = 1 To XportArea.Rows.Count
If XportArea.Cells(iRow, iCol).Text <> "" Then
Debug.Print XportArea.Cells(iRow, iCol).Text
 Print #iFnum, XportArea.Cells(iRow, iCol).Text
 
 End If
Next iRow
Next iCol
Close #iFnum


End Sub

Sub test()
Dim i As Long, x As Integer
Dim myRng As Range
Dim Criteria As Variant

Sheets("Sheet3").Activate
'range of data, not including header row (data starts in row 2)
Set myRng = Range("A2", Range("A65536").End(xlUp))

'check each item in "Town" list, add to Criteria variable
With myRng.Columns(1)
    Criteria = .Cells(1).Value
    For i = 2 To .Rows.Count
        If TextExists(.Cells(i).Value) = False Then
          Criteria = Criteria & "," & .Cells(i).Value
          
        End If
        Debug.Print Criteria
    Next i
End With
Criteria = Split(Criteria, ",")
Debug.Print Criteria(x)

With Rows("1:1")
.AutoFilter 'turn on autofilter
For x = LBound(Criteria) To UBound(Criteria)
        'filter "Town" column using criteria
    .AutoFilter field:=1, Criteria1:=Criteria(x)
    'With myRng.SpecialCells(xlCellTypeVisible)
        '***instead of this portion of code, try replacing it with a call to your Export macro
    Call Export(Criteria)
   'End With
       '**********
    Next x 'display filter results for next item
    
  .AutoFilter 'turn off autofilter
End With

End Sub


Private Function TextExists(currText)
'   Returns TRUE if text already exists in the Criteria variable _
(no duplicates should be in list)
Dim x As Variant
On Error Resume Next
x = WorksheetFunction.Search(currText, Criteria)
If Err = 0 Then TextExists = True Else TextExists = False
End Function

It is currently filtering the 1st state - alabama but when the next x occurs it does advance. Thanks again for your help.

jacknc · Dec 1, 2005

Kristy,

I finally got it to work. Although it wasnt exactly what i wanted to do. For some reason I couldnt get the array to work with the script you supplied. It has to be something on my end. I have pulled enough hair out to figure it out for now.

All I did to solve my problem was to insert an criteria array right before the criteria split. Here is what I have:

Code:

Sub test()
Dim i As Long, x As Integer
Dim myRng As Range
Dim criteria As Variant

Sheets("Sheet3").Activate
'range of data, not including header row (data starts in row 2)
'Set myRng = Range("A2", Range("A65536").End(xlUp))

'check each item in "Town" list, add to Criteria variable
'With myRng.Columns(1)
 '   criteria = .Cells(1).Value
  ' For i = 2 To .Rows.Count
   '  If TextExists(.Cells(i).Value) = False Then
    ' criteria = criteria & "," & .Cells(i).Value
    'Debug.Print criteria
     'End If
       
    'Next i
'End With

criteria = "Alabama,Alaska,Arizona,Arkansas,California,Colorado,Connecticut,Delaware,Florida,Georgia,Hawaii,Idaho,Illinois,Indiana,Iowa,Kansas,Kentucky,Louisiana,Maine,Maryland,Massachusetts,Michigan,Minnesota,Mississippi,Missouri,Montana,Nebraska,Nevada,New Hampshire,New Jersey,New Mexico,New York,North Carolina,North Dakota,Ohio,Oklahoma,Oregon,Pennsylvania,Rhode Island,South Carolina,South Dakota,Tennessee,Texas,Utah,Vermont,Virginia,Washington,West Virginia,Wisconsin,Wyoming"
criteria = Split(criteria, ",")
With Rows("1:1")
.AutoFilter 'turn on autofilter
For x = LBound(criteria) To UBound(criteria)
        Sheets("Sheet3").Activate
        'filter "State" column using criteria
    .AutoFilter field:=1, Criteria1:=criteria(x)
    'With myRng.SpecialCells(xlCellTypeVisible)
        '***instead of this portion of code, try replacing it with a call to your Export macro
    Call Export(criteria)
   'End With
       '**********
    Next x 'display filter results for next item
    
  .AutoFilter 'turn off autofilter
End With
End Sub

Again, I really liked your approach of scanining col and coming up with array without duplicates. I wish I knew why I couldnt get it to work. I really appreciate all of your help.

Thanks,
Jack

Von Pookie · Dec 1, 2005

Yeah, with the array it can be kind of tricky. I have a chance to look at it now, though. I may be able to figure it out.

Von Pookie · Dec 1, 2005

Ok. I'm not exactly certain on what your Export code is doing, other than creating files, but this gave me 50 text files named for each state. This is set up with all of this code within the same module:

Dim Criteria As Variant, myRng As Range

Sub test()
Dim i As Long, x As Integer

Application.ScreenUpdating = False
'range of data, not including header row (data starts in row 2)
With Sheets("Sheet3")
 .Select
 Set myRng = .Range("A2", .Range("B65536").End(xlUp))

 'check each item in list, add to Criteria variable
 With myRng.Columns(1)
 Criteria = .Cells(1).Value
 For i = 2 To .Rows.Count
 If TextExists(.Cells(i).Value) = False Then
 Criteria = Criteria & "," & .Cells(i).Value
 End If
 Next i
 End With

 'make Criteria an array
 Criteria = Split(Criteria, ",")

 With Rows("1:1")
 .AutoFilter 'turn on autofilter
 For x = LBound(Criteria) To UBound(Criteria)
 'filter column A using criteria from array
 .AutoFilter field:=1, Criteria1:=Criteria(x)

 'call the Export macro
 Call Export
 Next x 'display filter results for next item

 .AutoFilter 'turn off autofilter
 End With
End With

Application.ScreenUpdating = True

End Sub
Private Function TextExists(currText)
' Returns TRUE if text already exists in the Criteria variable _
(no duplicates should be in list)
Dim x As Variant
On Error Resume Next
x = WorksheetFunction.Search(currText, Criteria)
If Err = 0 Then TextExists = True Else TextExists = False
End Function

Sub Export()
Dim Textfile As Variant
Dim XportArea As Range, Cel As Range
Dim i As Long, iCol As Long, iRow As Long
Dim LastRow As Long, iFnum As Integer, x As Integer
Dim Path As String, FileName As String
Dim SaveFile As String, ShName As Variant

'copy visible cells in columns A:B of sheet 3 (filtered results)
myRng.SpecialCells(xlCellTypeVisible).Copy

'paste to Sheet1
Sheets("Sheet1").Range("A1").PasteSpecial xlPasteValues

Path = "C:\test\"
Textfile = Sheets("Sheet1").Range("A2").Value
FileName = LCase(Replace(Textfile, " ", ""))
SaveFile = Path & FileName & ".txt"

If Textfile = False Then Exit Sub

On Error Resume Next
'open / create the textfile
iFnum = FreeFile

Open CStr(SaveFile) For Append As iFnum

'since you're performing the same thing these sheets, _
you can turn this into a loop
ShName = Array("Output#1", "Output#2", "Output#3", "Output#4", "Output#5")

For x = LBound(ShName) To UBound(ShName)
 If ShName(x) = "Output#4" Then
 ' Get number of columns value from sheet 1
 i = Sheets("Sheet1").Range("C2").Value
 Set XportArea = Sheets(ShName(x)).Range("B1").Resize(5, i)
 Else
 'Select the cells to export:
 With Sheets(ShName(x))
 Set XportArea = .Range([A1], .[A65536].End(xlUp))
 End With
 End If
 For iCol = 1 To XportArea.Columns.Count
 For iRow = 1 To XportArea.Rows.Count
 If XportArea.Cells(iRow, iCol).Text <> "" Then
 Print #iFnum, XportArea.Cells(iRow, iCol).Text
 Debug.Print XportArea.Cells(iRow, iCol).Text
 End If
 Next iRow
 Next iCol
Next x

Close #iFnum

End Sub

jacknc · Dec 9, 2005

Kristy,
I apoligize for taking so long to get back with you. I spent time with family and didnt feel like racking my brain. I just looked at your code and was very impressed with your doings. I only needed to make very minimal changes and everything worked perfect. Well except for one thing - THAT CRAZY array function. For some reason it ALWAYS skips one - the same one at that (Kansas) . What is odd though if I sort it descending and run macro it includes (Kansas) but skips another one. Could this be a memory issue? Column A has states listed starting at row 2. This goes to row 3146 because Col B has its associated county.
Whats even more tricky is that I performed that exact same tes with a single column of 50 states (50 rows - nothing in other columns). And I got the EXACT same results - no kansas - or if i sorted descending i got kansas but didnt get another state.
I am looking at debug.print to determine this. Am I missing something?

Thanks again.
Jack

Von Pookie · Dec 9, 2005

I'm not sure. Where I remember it working fine when I used actual state names, I'm trying it again on letters a-z--and it's skipping some. It's filtering them, but it's just not making all of the files. Weird.

Could you send me your file? Just the sheet with the states/countries would really be all I need to see, I think.

Edit: I just ran across something--if the name/letter being filtered only appears once, only the 1 cell will be copied to Sheet1. You're getting the name for the txt file from Sheet1 cell A2--which could be anything.

For example, "d" appears in my list 2 times. When I filter, for that, those 2 cells are then copied onto Sheet1 A1, resulting in data in A1:A2. The file is named accordingly.

When I then filter for "e", there is only 1 instance of it in the list. When I copy that to A1, the value of A2 is still "d" and that is picked up as the name for the file, and is saved. Then it continues on, leaving me without an "e.txt" along with some others.

Maybe change this

Code:

Textfile = Sheets("Sheet1").Range("A2").Value

to look at A1 instead?

loop through autofilter drop down

jacknc

Board Regular

Excel Facts

Von Pookie

MrExcel MVP

jacknc

Board Regular

Von Pookie

MrExcel MVP

jacknc

Board Regular

jacknc

Board Regular

Von Pookie

MrExcel MVP

Von Pookie

MrExcel MVP

jacknc

Board Regular

Von Pookie

MrExcel MVP

Similar threads

Forum statistics

Share this page

loop through autofilter drop down

Board Regular

Excel Facts

MrExcel MVP

Board Regular

MrExcel MVP

Board Regular

Board Regular

MrExcel MVP

MrExcel MVP

Board Regular

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock