Filtering results

[GazMo]

I have Spreadhseet that contains 2 main workbooks (like databases) - on
for Suppliers and one for Customers ... I have written a macro in th
suppliers workbook that creates new worksheets for each different cod
no and names the tab accordingly. (based o
http://www.contextures.com/excelfiles.html/AdvFilterRepFiltered.xls)

Now I want to add a macro in the Customer workbook that will do th
same but put the relevant Customer data (including titles) in th
relevant tab (if already created) UNDER any existing data, and als
create a new tab if one hasnt been created already from the Supplie
workbook.

Any ideas ???

Cheers al

 

[Ron de Bruin]

Try this one

Copy the macro and functions in a normal module in the Customer workbook

Change the sheet name and range to yours

Set ws1 = Sheets("Sheet1")
Set rng = ws1.Range("A1:A100")



Sub Copy_With_AdvancedFilter()
Dim ws1 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim Lr As Long

Set ws1 = Sheets("Sheet1")
Set rng = ws1.Range("A1:A100")
'Use a Dynamic range name, http://www.contextures.com/xlNames01.html#Dynamic
'This example filter on the first column in the range (change this if needed)

With ws1
rng.Columns(1).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True
'You see that the last two columns of the worksheet are used to make a Unique list
'and add the CriteriaRange.(you can't use this macro if you use this columns)
Lrow = .Cells(Rows.Count, "IV").End(xlUp).Row
.Range("IU1").Value = .Range("IV1").Value

For Each cell In .Range("IV2:IV" & Lrow)
.Range("IU2").Value = cell.Value

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
Else
Set WSNew = Sheets(cell.Value)
End If

Lr = LastRow(Sheets(cell.Value))

rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=WSNew.Range("A" & Lr + 1), _
Unique:=False
Next
.Columns("IU:IV").Clear
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