Triple Filter? Ron de Bruin Code.
I'm trying to create a type of triple filter. I love the Ron de Bruin code:
(http://www.rondebruin.nl/copy5.htm#AutoFilter) I had the code working fine, for finding one single criteria in one column. Now I am wondering if I can apply this filtering technique three times as the names I am searching for can appear in Column F, Column K, and Column P. The names wont appear in all three places on the same row, but, just for example, one name may appear in Column F, rows(1:20), then appear in Column K, rows(100:130), and may appear again in Column P, rows (220:250). Is it possible to get the macro to somehow loop, and find all three occurrences of a single names in three column, and then copy paste into a single file in a folder? I think I could do this pretty easily with an Access Query, but I dont have Access installed on my computer. :( Please let me know if it can be done. The code that I have now is listed below: Sub Copy_To_Workbooks() Dim CalcMode As Long Dim ws1 As Worksheet Dim ws2 As Worksheet Dim WSNew As Worksheet Dim rng As Range Dim cell As Range Dim Lrow As Long Dim foldername As String Dim myPath As String Dim FieldNum As Integer Dim FieldNum1 As Integer Dim FieldNum2 As Integer Dim FileExtStr As String Dim FileFormatNum As Long 'Name of the sheet with your data Set ws1 = Sheets("Sheet1") '<<< Change 'Determine the Excel version and file extension/format If Val(Application.Version) < 12 Then 'You use Excel 97-2003 FileExtStr = ".xls": FileFormatNum = -4143 Else 'You use Excel 2007 If ws1.Parent.FileFormat = 56 Then FileExtStr = ".xls": FileFormatNum = 56 Else FileExtStr = ".xlsx": FileFormatNum = 51 End If End If 'Set filter range : A1 is the top left cell of your filter range and 'the header of the first column, D is the last column in the filter range Set rng = ws1.Range("A1:X" & Rows.Count) 'Set Field number of the filter column 'This example filters on the first field in the range(change the field if needed) 'In this case the range starts in A so Field:=1 is column A, 2 = column B, ...... FieldNum = 6 FieldNum1 = 11 FieldNum2 = 16 With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With ' Add worksheet to copy/Paste the unique list Set ws2 = Worksheets.Add 'Fill in the path\folder where you want the new folder with the files 'you can use also this "C:\Users\Ron\test" 'MyPath = Application.DefaultFilePath myPath = "C:\Ryan" 'Add a slash at the end if the user forget it If Right(myPath, 1) < "\" Then myPath = myPath & "\" End If 'Create folder for the new files foldername = myPath '& Format(Now, "yyyy-mm-dd") & "\" 'MkDir foldername With ws2 'first we copy the Unique data from the filter field to ws2 rng.Columns(FieldNum).AdvancedFilter _ Action:=xlFilterCopy, _ CopyToRange:=.Range("A1"), Unique:=True rng.Columns(FieldNum1).AdvancedFilter _ Action:=xlFilterCopy, _ CopyToRange:=.Range("A1"), Unique:=True rng.Columns(FieldNum2).AdvancedFilter _ Action:=xlFilterCopy, _ CopyToRange:=.Range("A1"), Unique:=True 'loop through the unique list in ws2 and filter/copy to a new workbook Lrow = .Cells(Rows.Count, "A").End(xlUp).Row For Each cell In .Range("A2:A" & Lrow) 'Add new workbook with one sheet Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 'Firstly, remove the AutoFilter ws1.AutoFilterMode = False 'Filter the range rng.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value rng.AutoFilter Field:=FieldNum1, Criteria1:="=" & cell.Value rng.AutoFilter Field:=FieldNum2, Criteria1:="=" & cell.Value 'Copy the visible data and use PasteSpecial to paste to the new worksheet ws1.AutoFilter.Range.Copy With WSNew.Range("A1") ' Paste:=8 will copy the columnwidth in Excel 2000 and higher .PasteSpecial Paste:=8 .PasteSpecial xlPasteValues .PasteSpecial xlPasteFormats Application.CutCopyMode = False .Select End With ActiveSheet.Name = cell.Value 'Save the file in the new folder and close it WSNew.Parent.SaveAs foldername & " Value = " _ & cell.Value & FileExtStr, FileFormatNum WSNew.Parent.Close False 'Close AutoFilter ws1.AutoFilterMode = False Next cell 'Delete the ws2 sheet On Error Resume Next Application.DisplayAlerts = False .Delete Application.DisplayAlerts = True On Error GoTo 0 End With MsgBox "Look in " & foldername & " for the files" With Application .ScreenUpdating = True .Calculation = CalcMode End With End Sub Function lastrow(sh As Worksheet) On Error Resume Next lastrow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlValues, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function Function SheetExists(SName As String, _ Optional ByVal WB As Workbook) As Boolean 'Chip Pearson On Error Resume Next If WB Is Nothing Then Set WB = ThisWorkbook SheetExists = CBool(Len(WB.Sheets(SName).Name)) End Function Regards, Ryan--- -- RyGuy |
Triple Filter? Ron de Bruin Code.
Resolved!! Not elegant, but I just run the macro three times,
copying/pasting the next results under the prior results, each time. The three columns come from an InputBox: Sub Copy_To_Worksheets_2() ' This sub uses the functions LastRow and SheetExists Dim CalcMode As Long Dim ws1 As Worksheet Dim ws2 As Worksheet Dim WSNew As Worksheet Dim rng As Range Dim cell As Range Dim Lrow As Long Dim DestRange As Range Dim FieldNum As Integer Dim Lr As Long Dim KeyCol As Integer KeyCol = InputBox("What column #?) 'Name of the sheet with your data Set ws1 = Sheets("Sheet1") '<<< Change 'Set filter range : A1 is the top left cell of your filter range and 'the header of the first column, D is the last column in the filter range Set rng = ws1.Range("A1:X" & Rows.Count) 'Set Field number of the filter column 'This example filters on the first field in the range(change the field if needed) 'In this case the range starts in A so Field:=1 is column A, 2 = column B, ...... FieldNum = KeyCol With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With ' Add a worksheet to copy the a unique list and add the CriteriaRange Set ws2 = Worksheets.Add With ws2 'first we copy the Unique data from the filter field to ws2 rng.Columns(FieldNum).AdvancedFilter _ Action:=xlFilterCopy, _ CopyToRange:=.Range("A1"), Unique:=True 'loop through the unique list in ws2 and filter/copy to a worksheet Lrow = .Cells(Rows.Count, "A").End(xlUp).Row For Each cell In .Range("A2:A" & Lrow) If SheetExists(cell.Value) = False Then Set WSNew = Sheets.Add On Error Resume Next WSNew.Name = cell.Value If Err.Number 0 Then MsgBox "Change the name of : " & WSNew.Name & " manually" Err.Clear End If On Error GoTo 0 Set DestRange = WSNew.Range("A1") Else Set WSNew = Sheets(cell.Text) Lr = LastRow(WSNew) Set DestRange = WSNew.Range("A" & Lr + 1) End If 'Firstly, remove the AutoFilter ws1.AutoFilterMode = False 'Filter the range rng.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value 'Copy the visible data and use PasteSpecial to paste to the worksheet ws1.AutoFilter.Range.Copy With DestRange .Parent.Select ' Paste:=8 will copy the columnwidth in Excel 2000 and higher .PasteSpecial Paste:=8 .PasteSpecial xlPasteValues .PasteSpecial xlPasteFormats Application.CutCopyMode = False .Select End With ' Delete the header row if you copy to a existing worksheet If Lr 0 Then WSNew.Range("A" & Lr + 1).EntireRow.Delete 'Close AutoFilter ws1.AutoFilterMode = False Lr = 0 Next cell 'Delete the ws2 sheet On Error Resume Next Application.DisplayAlerts = False .Delete Application.DisplayAlerts = True On Error GoTo 0 End With With Application .ScreenUpdating = True .Calculation = CalcMode End With Sheets("Sheet1").Select End Sub Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlValues, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function Function SheetExists(SName As String, _ Optional ByVal WB As Workbook) As Boolean 'Chip Pearson On Error Resume Next If WB Is Nothing Then Set WB = ThisWorkbook SheetExists = CBool(Len(WB.Sheets(SName).Name)) End Function -- RyGuy "ryguy7272" wrote: I'm trying to create a type of triple filter. I love the Ron de Bruin code: (http://www.rondebruin.nl/copy5.htm#AutoFilter) I had the code working fine, for finding one single criteria in one column. Now I am wondering if I can apply this filtering technique three times as the names I am searching for can appear in Column F, Column K, and Column P. The names wont appear in all three places on the same row, but, just for example, one name may appear in Column F, rows(1:20), then appear in Column K, rows(100:130), and may appear again in Column P, rows (220:250). Is it possible to get the macro to somehow loop, and find all three occurrences of a single names in three column, and then copy paste into a single file in a folder? I think I could do this pretty easily with an Access Query, but I dont have Access installed on my computer. :( Please let me know if it can be done. The code that I have now is listed below: Sub Copy_To_Workbooks() Dim CalcMode As Long Dim ws1 As Worksheet Dim ws2 As Worksheet Dim WSNew As Worksheet Dim rng As Range Dim cell As Range Dim Lrow As Long Dim foldername As String Dim myPath As String Dim FieldNum As Integer Dim FieldNum1 As Integer Dim FieldNum2 As Integer Dim FileExtStr As String Dim FileFormatNum As Long 'Name of the sheet with your data Set ws1 = Sheets("Sheet1") '<<< Change 'Determine the Excel version and file extension/format If Val(Application.Version) < 12 Then 'You use Excel 97-2003 FileExtStr = ".xls": FileFormatNum = -4143 Else 'You use Excel 2007 If ws1.Parent.FileFormat = 56 Then FileExtStr = ".xls": FileFormatNum = 56 Else FileExtStr = ".xlsx": FileFormatNum = 51 End If End If 'Set filter range : A1 is the top left cell of your filter range and 'the header of the first column, D is the last column in the filter range Set rng = ws1.Range("A1:X" & Rows.Count) 'Set Field number of the filter column 'This example filters on the first field in the range(change the field if needed) 'In this case the range starts in A so Field:=1 is column A, 2 = column B, ...... FieldNum = 6 FieldNum1 = 11 FieldNum2 = 16 With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False End With ' Add worksheet to copy/Paste the unique list Set ws2 = Worksheets.Add 'Fill in the path\folder where you want the new folder with the files 'you can use also this "C:\Users\Ron\test" 'MyPath = Application.DefaultFilePath myPath = "C:\Ryan" 'Add a slash at the end if the user forget it If Right(myPath, 1) < "\" Then myPath = myPath & "\" End If 'Create folder for the new files foldername = myPath '& Format(Now, "yyyy-mm-dd") & "\" 'MkDir foldername With ws2 'first we copy the Unique data from the filter field to ws2 rng.Columns(FieldNum).AdvancedFilter _ Action:=xlFilterCopy, _ CopyToRange:=.Range("A1"), Unique:=True rng.Columns(FieldNum1).AdvancedFilter _ Action:=xlFilterCopy, _ CopyToRange:=.Range("A1"), Unique:=True rng.Columns(FieldNum2).AdvancedFilter _ Action:=xlFilterCopy, _ CopyToRange:=.Range("A1"), Unique:=True 'loop through the unique list in ws2 and filter/copy to a new workbook Lrow = .Cells(Rows.Count, "A").End(xlUp).Row For Each cell In .Range("A2:A" & Lrow) 'Add new workbook with one sheet Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 'Firstly, remove the AutoFilter ws1.AutoFilterMode = False 'Filter the range rng.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value rng.AutoFilter Field:=FieldNum1, Criteria1:="=" & cell.Value rng.AutoFilter Field:=FieldNum2, Criteria1:="=" & cell.Value 'Copy the visible data and use PasteSpecial to paste to the new worksheet ws1.AutoFilter.Range.Copy With WSNew.Range("A1") ' Paste:=8 will copy the columnwidth in Excel 2000 and higher .PasteSpecial Paste:=8 .PasteSpecial xlPasteValues .PasteSpecial xlPasteFormats Application.CutCopyMode = False .Select End With ActiveSheet.Name = cell.Value 'Save the file in the new folder and close it WSNew.Parent.SaveAs foldername & " Value = " _ & cell.Value & FileExtStr, FileFormatNum WSNew.Parent.Close False 'Close AutoFilter ws1.AutoFilterMode = False Next cell 'Delete the ws2 sheet On Error Resume Next Application.DisplayAlerts = False .Delete Application.DisplayAlerts = True On Error GoTo 0 End With MsgBox "Look in " & foldername & " for the files" With Application .ScreenUpdating = True .Calculation = CalcMode End With End Sub Function lastrow(sh As Worksheet) On Error Resume Next lastrow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlValues, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function Function SheetExists(SName As String, _ Optional ByVal WB As Workbook) As Boolean 'Chip Pearson On Error Resume Next If WB Is Nothing Then Set WB = ThisWorkbook SheetExists = CBool(Len(WB.Sheets(SName).Name)) End Function Regards, Ryan--- -- RyGuy |
All times are GMT +1. The time now is 09:55 AM. |
Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
ExcelBanter.com