Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Triple Filter | Excel Programming | |||
Email code Question to Ron de Bruin Please | Excel Programming | |||
Triple lookup? | Excel Worksheet Functions | |||
Ron De Bruin Code modification needed when naming copied worksheet | Excel Programming | |||
help getting winzip code from RONs de bruin site | Excel Programming |