Sub Create_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 FileExtStr As String
Dim FileFormatNum As Long
'Name of the sheet with your data
Set ws1 = Sheets("Summary") '<<< Change
'Copying the Project information in the template file
Range("C2:C7").Select
Selection.Copy
Workbooks.Open Filename:="C:\Excel Templates\Reinf. for Walls.xlsm"
Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("I12").Select
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:= _
"C:\Excel Templates\Reinf. for Walls - Temp.xlsm", FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
ActiveWorkbook.Save
ActiveWorkbook.Close
Range("D10").Select
'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 = ".xlsm": FileFormatNum = 52
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("B9:AB" & Rows.Count)
'Set Field number of the filter column
'This example filters on the first field in the range(change the field if needed)
FieldNum = 2
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 = "C:\"
'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 = "C:\All Files at " & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"
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
'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)
Workbooks.Open ("C:\Excel Templates\Reinf. for Walls - Temp.xlsm")
Set WSNew = ActiveWorkbook.Worksheets(1)
'Firstly, remove the AutoFilter
ws1.AutoFilterMode = False
'Filter the range
rng.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value
'
'Save the file in the new folder and close it
WSNew.Parent.SaveAs foldername & 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
