Create Workbooks from the Data in a Worksheet
Assuming that the sheet containing the data is the active sheet, the following macro creates a workbook for each set of data that has the same value in Column A, saves and names each workbook after the value in Column A, and places each one in a the same newly created folder...
'Force the explicit
declaration of variables
Option Explicit
Sub
CreateWorkbooks()
'Declare the variables
Dim strDestPath As String
Dim
strDestFolder As
String
Dim
strSaveAsFilename As
String
Dim strFileExt As String
Dim strBadChars As String
Dim Msg As String
Dim wkbSource As Workbook
Dim wksSource As Worksheet
Dim wkbDest As Workbook
Dim wksDest As Worksheet
Dim wksTemp As Worksheet
Dim rngMyRange As Range
Dim
rngUniqueVals As
Range
Dim rngCell As Range
Dim
FileFormatNum As
Long
Dim CalcMode As Long
Dim LastRow As Long
Dim LastCol As Long
Dim CellCount As Long
Dim i As Long
Dim Aborted As Boolean
'Set the active workbook
Set wkbSource =
ActiveWorkbook
'Set the active worksheet
Set wksSource =
ActiveSheet
With wksSource
'Turn off the AutoFilter
.AutoFilterMode
= False
'Find the last used row
LastRow
= .Cells.Find( _
What:="*",
_
After:=.Range("A1"),
_
LookIn:=xlFormulas,
_
LookAt:=xlPart,
_
SearchOrder:=xlByRows,
_
SearchDirection:=xlPrevious,
_
MatchCase:=False).Row
'Set the range for the filter
(change the range accordingly)
Set rngMyRange =
.Range("A1:D" & LastRow)
End With
'Specify the path for the new
folder and files
strDestPath =
"C:\Users\Domenic\Documents\"
'Make sure that the path ends
in a backslash
If
Right(strDestPath, 1) <> "\" Then strDestPath
= strDestPath & "\"
'Define the path to the new
folder for the files
strDestFolder = strDestPath
& Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"
'Create the new folder for
the files
MkDir strDestFolder
'Set the file extension and
format
If
Val(Application.Version) < 12 Then
strFileExt
= ".xls"
FileFormatNum
= -4143
Else
If
wkbSource.FileFormat = 56 Then
strFileExt
= ".xls"
FileFormatNum
= 56
Else
strFileExt
= ".xlsx"
FileFormatNum
= 51
End If
End If
'Define the illegal
characters for a filename
strBadChars =
"<>?[]:|*"
'Change the settings for
Calculation, EnableEvents, and ScreenUpdating
With Application
CalcMode =
.Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
'Create and set a temporary
worksheet to store the unique values
Set wksTemp =
wkbSource.Worksheets.Add
'Filter for unique values and
copy them to the temporary worksheet
rngMyRange.Columns(1).AdvancedFilter
_
Action:=xlFilterCopy,
_
CriteriaRange:="",
_
CopyToRange:=wksTemp.Range("A1"),
_
Unique:=True
'Set the range for the unique
values in the temporary worksheet
With wksTemp
Set
rngUniqueVals = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
End With
'Loop through each unique
value in the temporary worksheet
For Each rngCell In rngUniqueVals
'Filter for the current
unique value
rngMyRange.AutoFilter
Field:=1, Criteria1:="=" & _
Replace(Replace(Replace(rngCell.Value,
"~", "~~"), "*", "~*"), _
"?",
"~?")
'For versions of Excel prior
to 2010, check for the SpecialCells limit
If
Val(Application.Version) < 14 Then
On Error Resume Next
CellCount
= rngMyRange.Columns(1) _
.SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
On Error GoTo 0
If CellCount = 0
Then
Msg
= "The SpecialCells limit of 8,192 areas has been "
Msg
= Msg & vbNewLine
Msg
= Msg & "exceeded for the value """ & rngCell &
"""."
Msg
= Msg & vbNewLine & vbNewLine
Msg
= Msg & "Sort the data, and try again!"
MsgBox
Msg, vbExclamation, "SpecialCells Limitation"
Aborted
= True
Exit For
End If
CellCount
= 0
End If
'Create and set a new
workbook for the destination workbook
Set wkbDest =
Workbooks.Add(xlWBATWorksheet)
'Set the destination worksheet
Set wksDest =
wkbDest.Worksheets(1)
'Copy the filtered data to
the destination worksheet
rngMyRange.SpecialCells(xlCellTypeVisible).Copy
With
wksDest.Range("A1")
.PasteSpecial
Paste:=8 'column
width for Excel 2000 and later
.PasteSpecial
Paste:=xlPasteValues
.PasteSpecial
Paste:=xlPasteFormats
.Select
End With
'Cancel Copy mode
Application.CutCopyMode
= False
'Define the SaveAs filename
for new workbook using the current unique value
strSaveAsFilename
= rngCell.Value & strFileExt
'Replace any illegal
characters in the SaveAs filename with an underscore
For i = 1 To
Len(strBadChars)
strSaveAsFilename
= _
Replace(strSaveAsFilename,
Mid(strBadChars, i, 1), "_")
Next i
'If the SaveAs filename
already exists, add a date/time stamp to filename
If
Len(Dir(strDestFolder & strSaveAsFilename)) > 0 Then
strSaveAsFilename
= Replace(strSaveAsFilename, strFileExt, _
"
" & Format(Now, "yyyy-mm-dd hh-mm-ss") & strFileExt)
End If
'Save the workbook in the new
folder
wkbDest.SaveAs
_
Filename:=strDestFolder
& strSaveAsFilename, _
FileFormat:=FileFormatNum
'Close the workbook, without
saving it
wkbDest.Close
SaveChanges:=False
Next rngCell
'Turn off the AutoFilter
wksSource.AutoFilterMode = False
'Delete the temporary
worksheet
Application.DisplayAlerts = False
wksTemp.Delete
Application.DisplayAlerts = True
'Restore the settings for
Calculation, EnableEvents, and ScreenUpdating
With Application
.Calculation
= CalcMode
.EnableEvents
= True
.ScreenUpdating
= True
End With
'Display a message box to
alert the user of completion
If Aborted = False Then
MsgBox
"Completed...", vbInformation
End If
End Sub
Where to Put the Code
- Open the workbook in which to store the code.
- Open the Visual Basic Editor (Alt+F11).
- Insert a standard module (Insert > Module).
- Copy/paste the above code into the module.
- Return to Microsoft Excel (Alt+Q).
- Save the workbook.
How to Use the Macro
- Display the Macro dialog box (Alt+F8).
- Click/select the macro called "CreateWorkbooks".
- Click/select "Run".
Sample Workbook: Download