Triple Filter? Ron de Bruin Code.

R

ryguy7272

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 won’t 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
don’t 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---
 
R

ryguy7272

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
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Add sheet 2
Keeping Validation References When Breaking out Spreadsheets Using 0
Feed List of Names into Ron de Bruin Code-Filter 6
Macro to generate worksheets 4
Keeping Validation References When Breakingout Spreadsheets 0
Modifying Ron's Sub Copy_To_Workbooks 2
Combining two different subs w/ similar variables 10
Using Ron's Sub Copy_to_Workbooks 6

Top