The reason, I believe, that it didn't quite work for you is that your data (as per the earlier sample that you supplied) starts on row 3 whereas the code from the other forum has it starting in row 2, as per the Poster's sample. So changing the cell references will do the trick for you.
However, I've attached a copy of your original sample with the code from the other forum slightly modified. It works nicely. You'll notice that I've reduced the size of the file as we only need a few rows of data to test it. The modified code is as follows:-
- Code: Select all
Sub CreateNewWbks()
Dim dic As Object
Dim rng As Range
Dim ws As Worksheet
Dim mypath As String
Dim lr As Long
Set dic = CreateObject("scripting.dictionary")
Set ws = Sheet1
mypath = ThisWorkbook.Path & "\"
lr = ws.Range("A" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ws
For nr = lr To 3 Step -1
If (Not dic.exists(.Cells(nr, "A").Value)) Then
dic.Add .Cells(nr, "A").Value, .Cells(nr, "A").Value
Set rng = .Range("A2:N" & .Cells(Rows.Count, 1).End(xlUp).Row)
rng.AutoFilter 1, .Range("A" & nr).Value
rng.Copy
Workbooks.Add
ActiveSheet.Paste
ActiveSheet.Columns.AutoFit
ActiveWorkbook.SaveAs Filename:=mypath & .Range("A" & nr).Value & ".xlsx"
ActiveWorkbook.Close
End If
Next
.AutoFilterMode = False
End With
MsgBox "Done!", vbExclamation
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
When the messagebox comes up with the message "Done", you'll know that all is ready for you. It will take a few seconds as there is a lot of work for the code to do.
The new work books will be stored in the same folder as the source file.
I hope that this solves it for you.
Cheerio,
vcoolio.