snowbounduk
07-16-2012, 06:30 AM
I am running the macro below to filter data and paste it to a nother workbook. It works fine when I use just this filter, it pastes nothing if the filter returns no data:
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
However, when I add these two filters, it works fine when the filters show data but when they return no records, it pastes every record, with no filters applied:
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
ws.Range(vTitles).AutoFilter Field:=12, Criteria1:="TRUE"
ws.Range(vTitles).AutoFilter Field:=9, Criteria1:="Open"
I've added the following line but it made no difference. Any suggestions as to how I can get it to return no data if the filters show nothing? Thanks in advance
On Error Resume Next
Sub ParseItemsIssues()
'Based on selected column, data is filtered to individual workbooks
'workbooks are named for the value plus today's date
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String
'Sheet with data in it
Set ws = Sheets("IssuesRAID2")
'Path to save files into, remember the final \
SvPath = "C:\Gordon Reports\tester1\files\tester3\"
'OpPath = "C:\Gordon Reports\tester1\ProjectRAID\"
'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
vTitles = "A1:L1"
'Choose column to evaluate from, column A = 1, B = 2, etc.
vCol = 1 'Application.InputBox("What column to split data by? " & vbLf _
'& vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 1, Type:=1)
'If vCol = 0 Then Exit Sub
'Spot bottom row of data
LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row
'Speed up macro execution
Application.ScreenUpdating = False
'Get a temporary list of unique values from column A
ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True
'Sort the temporary list
ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'Put list into an array for looping (values cannot be the result of formulas, must be constants)
MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))
'clear temporary worksheet list
ws.Range("EE:EE").Clear
'Turn on the autofilter, one column only is all that is needed
ws.Range(vTitles).AutoFilter
'Loop through list one value at a time
For Itm = 1 To UBound(MyArr)
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
ws.Range(vTitles).AutoFilter Field:=12, Criteria1:="TRUE"
ws.Range(vTitles).AutoFilter Field:=9, Criteria1:="Open"
On Error Resume Next
ws.Range("B2:K" & LR).Copy
'Workbooks.Open
Workbooks.Open ("C:\Gordon Reports\tester1\Project RAID" & "\" & MyArr(Itm) & " " & "RAID")
Sheets("Issues").Range("B12").PasteSpecial xlPasteValues
Sheets("Issues").Select
Range("B12").Select
If ActiveCell.Value = "Issue ID" Then Rows("12:12").EntireRow.ClearContents
ActiveWorkbook.Save 'As SvPath & MyArr(Itm) & "Issues", xlNormal
ActiveWorkbook.Close False
ws.Range(vTitles).AutoFilter Field:=vCol
Next Itm
'Cleanup
ws.AutoFilterMode = False
'MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!"
Application.ScreenUpdating = True
End Sub
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
However, when I add these two filters, it works fine when the filters show data but when they return no records, it pastes every record, with no filters applied:
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
ws.Range(vTitles).AutoFilter Field:=12, Criteria1:="TRUE"
ws.Range(vTitles).AutoFilter Field:=9, Criteria1:="Open"
I've added the following line but it made no difference. Any suggestions as to how I can get it to return no data if the filters show nothing? Thanks in advance
On Error Resume Next
Sub ParseItemsIssues()
'Based on selected column, data is filtered to individual workbooks
'workbooks are named for the value plus today's date
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String
'Sheet with data in it
Set ws = Sheets("IssuesRAID2")
'Path to save files into, remember the final \
SvPath = "C:\Gordon Reports\tester1\files\tester3\"
'OpPath = "C:\Gordon Reports\tester1\ProjectRAID\"
'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
vTitles = "A1:L1"
'Choose column to evaluate from, column A = 1, B = 2, etc.
vCol = 1 'Application.InputBox("What column to split data by? " & vbLf _
'& vbLf & "(A=1, B=2, C=3, etc)", "Which column?", 1, Type:=1)
'If vCol = 0 Then Exit Sub
'Spot bottom row of data
LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row
'Speed up macro execution
Application.ScreenUpdating = False
'Get a temporary list of unique values from column A
ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True
'Sort the temporary list
ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
'Put list into an array for looping (values cannot be the result of formulas, must be constants)
MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))
'clear temporary worksheet list
ws.Range("EE:EE").Clear
'Turn on the autofilter, one column only is all that is needed
ws.Range(vTitles).AutoFilter
'Loop through list one value at a time
For Itm = 1 To UBound(MyArr)
ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
ws.Range(vTitles).AutoFilter Field:=12, Criteria1:="TRUE"
ws.Range(vTitles).AutoFilter Field:=9, Criteria1:="Open"
On Error Resume Next
ws.Range("B2:K" & LR).Copy
'Workbooks.Open
Workbooks.Open ("C:\Gordon Reports\tester1\Project RAID" & "\" & MyArr(Itm) & " " & "RAID")
Sheets("Issues").Range("B12").PasteSpecial xlPasteValues
Sheets("Issues").Select
Range("B12").Select
If ActiveCell.Value = "Issue ID" Then Rows("12:12").EntireRow.ClearContents
ActiveWorkbook.Save 'As SvPath & MyArr(Itm) & "Issues", xlNormal
ActiveWorkbook.Close False
ws.Range(vTitles).AutoFilter Field:=vCol
Next Itm
'Cleanup
ws.AutoFilterMode = False
'MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!"
Application.ScreenUpdating = True
End Sub