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).
Last edited by abhay_547; Feb 6th, 2018 at 01:46 PM.
Re: Loop through a range and filter data based on the criteria in the columns cells
can you post a sample workbook with some data and desired result?
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case. Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
Re: Loop through a range and filter data based on the criteria in the columns cells
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.
Re: Loop through a range and filter data based on the criteria in the columns cells
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
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case. Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
Re: Loop through a range and filter data based on the criteria in the columns cells
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
Re: Loop through a range and filter data based on the criteria in the columns cells
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
Last edited by westconn1; Feb 8th, 2018 at 02:32 AM.
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case. Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
Re: Loop through a range and filter data based on the criteria in the columns cells
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?
Feeling like a fly on the inside of a closed window (Thunk!)
If I post a lot, it is because I am bored at work! ;D Or stuck...
* Anything I post can be only my opinion. Advice etc is up to you to persue...
Re: Loop through a range and filter data based on the criteria in the columns cells
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
Re: Loop through a range and filter data based on the criteria in the columns cells
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
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
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
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case. Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
Re: Loop through a range and filter data based on the criteria in the columns cells
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
Last edited by abhay_547; Feb 11th, 2018 at 11:34 AM.
Re: Loop through a range and filter data based on the criteria in the columns cells
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?
Feeling like a fly on the inside of a closed window (Thunk!)
If I post a lot, it is because I am bored at work! ;D Or stuck...
* Anything I post can be only my opinion. Advice etc is up to you to persue...
i would avoid the selecting, activating and use of activesheet
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case. Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
Re: Loop through a range and filter data based on the criteria in the columns cells
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
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case. Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
Re: Loop through a range and filter data based on the criteria in the columns cells
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
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.
Re: Loop through a range and filter data based on the criteria in the columns cells
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
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$']"
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case. Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
Re: Loop through a range and filter data based on the criteria in the columns cells
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")
as your sample was an .xls, i just went with that, easier for me anyway
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case. Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
Re: Loop through a range and filter data based on the criteria in the columns cells
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
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case. Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
Re: Loop through a range and filter data based on the criteria in the columns cells
remove the enclosing ' '
Code:
sql = "select * from [rawdata$]"
a change between ADO and ACE
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case. Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete