Hello,
I have two files with similar data. I am using Ron de Bruin's
fantastic "Create new workbook for all unique values" code on his
website to seperate the files. I am using the same unique value, for
instance "connectors," "cables," "metal", to seperate both files.
What I am looking to do is to save the output of both files in the
same workbook yet on different worksheets.
Thank you all in advance for your help. I have used the advice found
here many times!!
I have posted Ron's code below:
Sub Copy_With_AdvancedFilter_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
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

" & Rows.Count)
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
' Add worksheet to copy the a unique list and add the
CriteriaRange
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
'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 hh-mm-ss") & "\"
MkDir foldername
With ws2
'This example filters on the first column in the range
'first we copy the Unique data from this column to ws2
rng.Columns(1).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("B1"), Unique:=True
'Then give A1 the same value as B1 (header of column 1) in ws2
.Range("A1").Value = .Range("B1").Value
'loop through the unique list in ws2 and filter/copy to a new
workbook
Lrow = .Cells(Rows.Count, "B").End(xlUp).Row
For Each cell In .Range("B2:B" & Lrow)
.Range("A2").Value = "=" & Chr(34) & "=" & cell.Value &
Chr(34)
Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("A1:A2"), _
CopyToRange:=WSNew.Range("A1"), _
Unique:=False
WSNew.Columns.AutoFit
'Save the file in the newfolder and close it
WSNew.Parent.SaveAs foldername & " Value = " _
& cell.Value, ws1.Parent.FileFormat
WSNew.Parent.Close False
Next
'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