Loop through a range and filter data based on the criteria in the columns cells

I have a worksheet named "Rawdata" and another worksheet named as "Mapping" and multiple other worksheets in a workbook. The Rawdata consists of some sales data which has 2 columns .i.e. States (e.g. Arizona, Albama, California etc) and another column consists of the cities from those states (e.g. Gilbert, Phoenix etc.), The multiple other worksheets which I have in the workbook are named after each state. The mapping tab consists of States column and City column in which City column consists multiple Cities entered against the each state separated by commas. Now I have used the below code to filter the Raw data worksheet based on the criteria which is entered in the Mapping tab column B .i.e. Cities. So the idea is to filter the data from Rawdata tab for each state and copy it into the respective state tab.

Code:

---

Sub FilterDataMacro()
Dim CopyShtname As String
CopyShtname = ThisWorkbook.Sheets("Mapping").Range("A2").Value
Dim FilterCriteria As Variant
FilterCriteria = Split(ThisWorkbook.Sheets("Mapping").Range("B2").Value, ",")

ActiveSheet.Range("$A$1:$U$10000").AutoFilter Field:=11, Criteria1:=FilterCriteria, Operator:=xlFilterValues
Selection.SpecialCells(xlCellTypeVisible).Select ' while selecting i want to exclude the header row
Selection.Copy
Sheets(CopyShtname).Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub

---

Is there a way I can run the above code in loop for a range of cells .i.e. Column A and B in mapping tab, where I have the Sheet name (in which the data needs to be pasted post filtering) in Column A and the Criteria in Column B (separated by Commas).

can you post a sample workbook with some data and desired result?

Quote:

---

Originally Posted by westconn1

can you post a sample workbook with some data and desired result?

---

Attached is the sample data workbook. It consists of dummy data similar to my workbook data and the macro. the filtered data should be copied into individual state sheets and the macro should loop through Mapping sheet for Criteria and Destination sheetnames.

you can test this to see of it does what you want

Code:

---

Sub FilterDataMacro()
    Dim CopyShtname As String
    Dim FilterCriteria As Variant
    With ThisWorkbook.Sheets("Mapping")
        For rw = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
            CopyShtname = .Cells(rw, 1).Value
            If Not wsexists(CopyShtname) Then ThisWorkbook.Sheets.Add(, ThisWorkbook.Sheets("mapping")).Name = CopyShtname
            FilterCriteria = Split(.Cells(rw, 2).Value, ",")
            With ThisWorkbook.Sheets("raw data")
                .Range("$A$1:$U$10000").AutoFilter Field:=10, Criteria1:=FilterCriteria ', Operator:=xlfilter
                .Cells.SpecialCells(xlCellTypeVisible).Copy ThisWorkbook.Sheets(CopyShtname).Range("A1")
                .ShowAllData
            End With
        Next
    End With
End Sub
Function wsexists(nm As String) As Boolean
For Each ws In ThisWorkbook.Sheets
    If ws.Name = nm Then wsexists = True: Exit Function
Next
End Function

---

i added a bit extra to create any missing state worksheets, if you want to avoid copying the header row to the state worksheets remove row 1 after copying

Quote:

---

Originally Posted by westconn1

you can test this to see of it does what you want

Code:

---

Sub FilterDataMacro()
    Dim CopyShtname As String
    Dim FilterCriteria As Variant
    With ThisWorkbook.Sheets("Mapping")
        For rw = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
            CopyShtname = .Cells(rw, 1).Value
            If Not wsexists(CopyShtname) Then ThisWorkbook.Sheets.Add(, ThisWorkbook.Sheets("mapping")).Name = CopyShtname
            FilterCriteria = Split(.Cells(rw, 2).Value, ",")
            With ThisWorkbook.Sheets("raw data")
                .Range("$A$1:$U$10000").AutoFilter Field:=10, Criteria1:=FilterCriteria ', Operator:=xlfilter
                .Cells.SpecialCells(xlCellTypeVisible).Copy ThisWorkbook.Sheets(CopyShtname).Range("A1")
                .ShowAllData
            End With
        Next
    End With
End Sub
Function wsexists(nm As String) As Boolean
For Each ws In ThisWorkbook.Sheets
    If ws.Name = nm Then wsexists = True: Exit Function
Next
End Function

---

i added a bit extra to create any missing state worksheets, if you want to avoid copying the header row to the state worksheets remove row 1 after copying

---

Its not filtering the data for all cities, e.g. I have below 13 cities mapped against Arizona state in the Mapping tab but it filters the Raw data tab for only Yuma city and copies the same into the Arizona worksheet. same thing is happening for all other states where there are more than once city mapped against a state, it working correctly only for District of Columbia since it has only one city mapped against it, that is washington. can you advise.

Avondale, Bullhead City, Chandler, Gilbert, Glendale, Mesa, Peoria, Phoenix, Scottsdale, Sierra Vista, Tempe, Tucson, Yuma

it would appear that autofilter is only finding the last city in the filters array

i will fix it later

edit: i did some further testing on a machine with a later version of excel
setting the operator to xlfiltervalues (as you had, but not valid in my version of excel) did resolve the problem
BUT i found that peoria was listed as a city in both arizona and illnois (no idea if actually both states have a city of that name, or that other cities may exist in multiple states) AND the results were not sorted, except by row

my preferred solution would probably be to filter by state, then possibly sort the pasted result by city, but i am not sure what result you really want

Code:

---

Sub FilterDataMacro()
Dim CopyShtname As String
CopyShtname = ThisWorkbook.Sheets("Mapping").Range("A2").Value
Dim FilterCriteria As Variant
FilterCriteria = Split(ThisWorkbook.Sheets("Mapping").Range("B2").Value, ",")

ActiveSheet.Range("$A$1:$U$10000").AutoFilter Field:=10, Criteria1:=FilterCriteria, Operator:=xlFilterValues
Selection.SpecialCells(xlCellTypeVisible).Select ' while selecting i want to exclude the header row
Selection.Copy
Sheets(CopyShtname).Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub


Public Sub SplitData()
    Dim wrk As Workbook
    Dim shtS As Worksheet
    Dim shtD As Worksheet
    Dim shtM As Worksheet
    Dim rng As Range
   
    Dim sWrk As String
    Dim sCity As String
    Dim lngMaxRow As Long
    Dim lngMaxCol As Long
    Dim lngCol As Long
    Dim lngRow As Long
    Dim lngCols(3) As Long
    Dim lngDestRow As Long
    Dim lngMapping As Long
   
    Set wrk = ActiveWorkbook
    Set shtS = wrk.Sheets("Raw Data")
    Set shtM = wrk.Sheets("mapping")
   
       
    lngMaxCol = shtS.Cells(1, 1).End(xlToRight).Column
    lngMaxRow = shtS.Cells(1, 1).End(xlDown).Row
   
    'sort data by country, state, city
    'assume the columns exist - otherwise sort will be wrong
    sWrk = "Country"
    lngCol = shtS.Range(shtS.Cells(1, 1), shtS.Cells(1, lngMaxCol)).Find(sWrk).Column
    If (shtS.Cells(1, lngCol) = sWrk) Then
        lngCols(0) = lngCol
        shtS.AutoFilter.Sort.SortFields.Add Key:=shtS.Range(shtS.Cells(2, lngCol), shtS.Cells(lngMaxRow, lngCol)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    End If
    sWrk = "State"
    lngCol = shtS.Range(shtS.Cells(1, 1), shtS.Cells(1, lngMaxCol)).Find(sWrk).Column
    If (shtS.Cells(1, lngCol) = sWrk) Then
        lngCols(1) = lngCol
        shtS.AutoFilter.Sort.SortFields.Add Key:=shtS.Range(shtS.Cells(2, lngCol), shtS.Cells(lngMaxRow, lngCol)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    End If
    sWrk = "City"
    lngCol = shtS.Range(shtS.Cells(1, 1), shtS.Cells(1, lngMaxCol)).Find("City").Column
    If (shtS.Cells(1, lngCol) = sWrk) Then
        lngCols(2) = lngCol
        shtS.AutoFilter.Sort.SortFields.Add Key:=shtS.Range(shtS.Cells(2, lngCol), shtS.Cells(lngMaxRow, lngCol)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    End If
   
    With shtS.AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   
    sWrk = ""
    sCity = ""
    lngMapping = 1
    For lngRow = 2 To lngMaxRow
        If (shtS.Cells(lngRow, lngCols(0)) = "United States") Then
            If (sWrk <> shtS.Cells(lngRow, lngCols(1))) Then
               
                If (lngMapping > 1) Then shtM.Cells(lngMapping, 2) = shtM.Cells(lngMapping, 2) & "," & sCity
               
                lngMapping = shtM.Cells(65535, 1).End(xlUp).Row + 1
                shtM.Cells(lngMapping, 1) = sWrk
               
                sWrk = shtS.Cells(lngRow, lngCols(1))
                sCity = shtS.Cells(lngRow, lngCols(2))
               
                'set sheet - if doesnt exist create it
                On Error Resume Next
                Set shtD = wrk.Sheets(sWrk)
                If Err Then
                    Err.Clear
                    Set shtD = wrk.Sheets.Add
                    shtD.Name = sWrk
                    shtS.Range(shtS.Cells(1, 1), shtS.Cells(1, lngMaxCol)).Copy
                    shtD.Cells(1, 1).PasteSpecial xlPasteAll
                    lngDestRow = 2
                   
                Else
                    lngDestRow = shtD.Cells(65535, 1).End(xlUp).Row
                End If
                On Error GoTo 0
            End If
           
            If (sCity <> shtS.Cells(lngRow, lngCols(2))) Then
                sCity = shtS.Cells(lngRow, lngCols(2))
                If shtM.Cells(lngMapping, 2) <> "" Then
                    shtM.Cells(lngMapping, 2) = shtM.Cells(lngMapping, 2) & "," & sCity
                Else
                    shtM.Cells(lngMapping, 2) = sCity
                End If
            End If
           
            shtS.Range(shtS.Cells(lngRow, 1), shtS.Cells(lngRow, lngMaxCol)).Copy
            shtD.Cells(lngDestRow, 1).PasteSpecial xlPasteAll
            lngDestRow = lngDestRow + 1
           
        End If
       
        If lngRow Mod 5 Then DoEvents
    Next
   
    Set shtD = Nothing
    Set shtS = Nothing
    Set wrk = Nothing
   
   
End Sub

---

I had a go... not the most elegant nor quick... Reckon with the filter you'd go faster... possibly just pivot the results to a temp sheet get the values and store then erase the pivot?

Quote:

---

Originally Posted by westconn1

it would appear that autofilter is only finding the last city in the filters array

i will fix it later

edit: i did some further testing on a machine with a later version of excel
setting the operator to xlfiltervalues (as you had, but not valid in my version of excel) did resolve the problem
BUT i found that peoria was listed as a city in both arizona and illnois (no idea if actually both states have a city of that name, or that other cities may exist in multiple states) AND the results were not sorted, except by row

my preferred solution would probably be to filter by state, then possibly sort the pasted result by city, but i am not sure what result you really want

---

I am using excel 2010 on my office pc and at home i have excel 2013 and on both i am having the same issue. In fact i am going to use this in office pc where i get the message "Excel cannot complete this task with available resources" when i run the above macro, also actually the state column is not reliable since it has lot of spell errors and blanks in the raw data tab hence I want to use the cities. also I am planning to keep the state named worksheets in a separate workbook which will be open while running macro. i made a small tweak and tried below but still it shows the same msg .i.e. excel cannot complete the task with available resources.

Code:

---

Sub FilterDataMacro()
    Dim CopyShtname As String
    Dim FilterCriteria As Variant
    With ThisWorkbook.Sheets("Mapping")
        For rw = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
            CopyShtname = .Cells(rw, 1).Value
            If Not wsexists(CopyShtname) Then Workbooks("Final Output.xlsx").Sheets.Add(, ThisWorkbook.Sheets("mapping")).Name = CopyShtname
            FilterCriteria = Split(.Cells(rw, 2).Value, ",")
            With ThisWorkbook.Sheets("raw data")
                .Range("$A$1:$U$10000").AutoFilter Field:=10, Criteria1:=FilterCriteria ', Operator:=xlfilter
                .Cells.SpecialCells(xlCellTypeVisible).Copy
                .ShowAllData
            End With
          Workbooks("Final Output.xlsx").Sheets(CopyShtname).Range("A1").Select
            ActiveSheet.Paste
        Next
    End With
End Sub
Function wsexists(nm As String) As Boolean
For Each ws In Workbooks("Final Output.xlsx").Sheets
    If ws.Name = nm Then wsexists = True: Exit Function
Next
End Function

---

Quote:

---

i.e. excel cannot complete the task with available resources.

---

it worked fine for me, but i was only using the small sample data
where do you get the error? can you test with the sample and with different amounts of data? my computer here is always working at maximum resource usage and i often have to close programs for others to work

Quote:

---

If Not wsexists(CopyShtname) Then Workbooks("Final Output.xlsx").Sheets.Add(, ThisWorkbook.Sheets("mapping")).Name = CopyShtname

---

adding a worksheet (if required) should fail as you are trying to add the new sheet after a sheet in a different workbook

from post #6

Quote:

---

setting the operator to xlfiltervalues (as you had, but not valid in my version of excel) did resolve the problem

---

did you try this? as it is still commented in the code as post #8, as i mainly work in excel 2000 some features are not available, including using arrays as criteria, but i tested in excel 2010, and all cities were found as far as i could see, though there was some problem with duplicate city as in post #6

i would paste to the state worksheet before .showalldata as would think that probably changes cutcopymode

if you determine that the error is the volume of the data, some other alternative method may be required to work with such large files, can you post a sample where it stops working

Ok. its showing the error msg "excel cannot complete the task with available resources" on the below line, for some sheets its able to copy and paste the data for example one of the state has only 74 lines so its able to filter and copy paste the data in the final output workbook in that respective state sheet but i believe it has got a limitation may be something above 100 row items is not getting handled by it and its showing the error:

Code:

---

ActiveSheet.Paste

---

Code:

---

Sub FilterDataMacro()
    Dim CopyShtname As String
    Dim FilterCriteria As Variant
    With ThisWorkbook.Sheets("Mapping")
        For rw = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
            CopyShtname = .Cells(rw, 1).Value
            If Not wsexists(CopyShtname) Then Workbooks("Final Output.xlsx").Sheets.Add(, ThisWorkbook.Sheets("mapping")).Name = CopyShtname
            FilterCriteria = Split(.Cells(rw, 2).Value, ",")
            With ThisWorkbook.Sheets("raw data")
                On Error Resume Next
                .ShowAllData
                .Range("$A$1:$U$10000").AutoFilter Field:=10, Criteria1:=FilterCriteria, Operator:=xlFilterValues
                .Cells.SpecialCells(xlCellTypeVisible).Copy             
            End With
            Workbooks("Final Output.xlsx").Activate
            Sheets(CopyShtname).Select
            Range("A1").Select
            ActiveSheet.Paste
        Next
    End With
End Sub
Function wsexists(nm As String) As Boolean
For Each ws In Workbooks("Final Output.xlsx").Sheets
    If ws.Name = nm Then wsexists = True: Exit Function
Next
End Function

---

can someone help with the above code.

Quote:

---

excel cannot complete the task with available resources

---

means you dont have enough memory... try this link


Although the test work book you posted plus my code... never had a problem either...
Perhaps you need to get a better computer ? Or borrow a better one to compare?

if you do not have enough resources to copy and paste you may need to look at some other method for transferring the data

Quote:

---

Workbooks("Final Output.xlsx").Activate
Sheets(CopyShtname).Select
Range("A1").Select
ActiveSheet.Paste

---

i would avoid the selecting, activating and use of activesheet

here is an alternative solution that does not use filtering or copy and paste, this may resolve you resources problem

Code:

---

Sub sql()
Dim cn As Connection, Rs As Recordset, rs2 As Recordset, cel As Range, sql As String

Set cn = New Connection
Set Rs = New Recordset
Set rs2 = New Recordset
With cn
    .Provider = "Microsoft.Jet.OLEDB.4.0"
    .ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties='Excel 8.0;hdr=yes'"
'"Extended Properties=""Excel 8.0;hdr=yes;IMEX=1;"""

    .Open
End With
sql = "select * from ['raw data$']"
With Sheets("Mapping")
    For rw = 2 To 16
        stat = .Cells(rw, 1)
        where = " where ([City]='"
        cits = .Cells(rw, 2)
        cita = Split(cits, ", ")
        For I = 0 To UBound(cita)
            where = where & Join(cita, "' or [City]='")
        Next
        where = Trim(where) & "')"
        'Debug.Print where
        rs2.Open sql & where, cn, adOpenStatic, adLockReadOnly
        Set cel = Sheets(stat).Range("a1")
        cel.Resize(, 21).Value = Sheets("raw data").Range("a1:u1").Value
        cel.Offset(1).CopyFromRecordset rs2
        rs2.Close
        where = ""
    Next
End With
cn.Close
End Sub

---

requires a reference to ms activex data objects, this is partially tested and appears to work correctly, you will have to test for problems with larger data files

It gets stuck on the below line and shows the error msg .i.e. "the microsoft jet database engine could not find the object "rawdata$". Make sure the object exists and you spell its name and the path name correctly. My sheet name is RawData without space in between

Code:

---

rs2.Open sql & where, cn, adOpenStatic, adLockReadOnly

---

If I add a space between RawData then it gets stuck on the below line. I don't have the state sheets in the macro file, I have the state sheets created in a separate file called Final Output.xlsx. and I want the filtered data to be pasted in the individual state sheet of final output file and if one of the state tab doesn't exist then it should add the same.

Code:

---

Set cel = Sheets(stat).Range("a1")

---

Quote:

---

if one of the state tab doesn't exist then it should add the same.

---

i provided a function to do that earlier, see post #4, which you modified to work with a different workbook, make sure you have fixed adding a worksheet as per the comment in post #9
to keep the function generic, you should pass the workbook object to the function along with the sheet name

Quote:

---

Set cel = Sheets(stat).Range("a1")

---

as the state sheet is in a different workbook, you need to fully qualify the sheet

Code:

---

Set cel = workbooks("final output").Sheets(stat).Range("a1")

---

same applies if the mapping sheet is in a different workbook
All the code i tested was based on the sample file where all the sheet were in the same workbook
the sample sheet name had a space Raw Data
if yours has no space just change to

Code:

---

sql = "select * from ['rawdata$']"

---

Ok. but I had already tried by removing the space in between in the select statement but still it shows the same error message .i.e. "the microsoft jet database engine could not find the object "rawdata$". Make sure the object exists and you spell its name and the path name correctly. i have the sheet named as "rawdata" which consists of main data in the macro workbook itself.
Is it something to do with the reference. I am using the reference to Microsoft AcitveX Data Objects 6.1 Library, so does it need to be different ?


for Set Cel, i have updated it to point to the final output workbook

Code:

---

Set cel = workbooks("final output.xlsx").Sheets(stat).Range("a1")

---

Quote:

---

Is it something to do with the reference.

---

is your workbook .xls or .xlsx, if it .xlsx may have to change the connection like

Code:

---

Provider=Microsoft.ACE.OLEDB.12.0;Data Source=c:\myFolder\myExcel2007file.xlsx;
Extended Properties="Excel 12.0 Xml;HDR=YES";

---

as your sample was an .xls, i just went with that, easier for me anyway

It's *.xlsm but rather than hard coding file name can i use below

Code:

---

Provider=Microsoft.ACE.OLEDB.12.0;"Data Source=" & ThisWorkbook.FullName & ";"
Extended Properties="Excel 12.0 Xml;HDR=YES";

---

that should work fine, but for .xlsm (which should have been obvious to me) change as below

Code:

---

Extended Properties="Excel 12.0 Macro;HDR=YES";

---

print the connection string to the immediate window to make sure it looks correct

now it shows the attached error message. I am testing it on my office machine with excel 2010. reference: Microsoft ActiveX Data Objects 6.1 Library

Code:

---

With cn
    .Provider = "Microsoft.ACE.OLEDB.12.0"
    .ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties='Excel 12.0 Macro;hdr=yes'"


    .Open
End With
sql = "select * from ['rawdata$']"

---

remove the enclosing ' '

Code:

---

sql = "select * from [rawdata$]"

---

a change between ADO and ACE