Create Workbooks from the Data in a Worksheet

Assuming that the sheet containing the data is the active sheet, the following procedure creates a workbook for each set of data that has the same value in Column B, names each workbook after the value in Column B, and saves them in the specified folder...

'Force the explicit declaration of variables
Option Explicit

Sub CreateWorkbooks()

    'Declare the variables
    Dim strDestPath 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 rngData As Range
    Dim rngUniqueVals As Range
    Dim rngCell As Range
    Dim FileFormatNum As Long
    Dim CalcMode As Long
    Dim LastRow As Long
    Dim CellCount As Long
    Dim i As Long
    Dim bAborted As Boolean
    'Check if the active sheet is a worksheet
    If TypeName(ActiveSheet) <> "Worksheet" Then
        MsgBox "Please make sure that the worksheet containing" & vbCrLf & _
            "the data is the active sheet, and try again!", vbExclamation
        Exit Sub
    End If
    'Check if the worksheet contains data
    If ActiveSheet.UsedRange.Rows.Count = 1 Then
        MsgBox "No data is available.  Please try again!", vbExclamation
        Exit Sub
    End If
    'Specify the path to the folder in which to save the newly created files
    strDestPath = "C:\Users\Domenic\Documents\"
    'Make sure that the path ends in a backslash
    If Right(strDestPath, 1) <> "\" Then strDestPath = strDestPath & "\"
    'Check if the path exists
    If Len(Dir(strDestPath, vbDirectory)) = 0 Then
        MsgBox "The path to your folder does not exist.  Please check" & vbCrLf & _
            "the path, and try again!", vbExclamation
        Exit Sub
    End If
    'Define the illegal characters for a filename
    strBadChars = "\/<>?[]:|*"""
    'Set the active workbook
    Set wkbSource = ActiveWorkbook
    'Set the active worksheet
    Set wksSource = ActiveSheet
    'Set the file extension and format
    If Val(Application.Version) < 12 Then
        strFileExt = ".xls"
        FileFormatNum = -4143
        If wkbSource.FileFormat = 56 Then
            strFileExt = ".xls"
            FileFormatNum = 56
            strFileExt = ".xlsx"
            FileFormatNum = 51
        End If
    End If
    'Change the settings for Calculation, EnableEvents, and ScreenUpdating
    With Application
       CalcMode = .Calculation
       .Calculation = xlCalculationManual
       .EnableEvents = False
       .ScreenUpdating = False
    End With
    'Turn off the AutoFilter
    wksSource.AutoFilterMode = False
    'Set the range for the source data
    Set rngData = wksSource.UsedRange
    'Create a temporary worksheet to store the unique values from Column B
    Set wksTemp = wkbSource.Worksheets.Add
    'Filter Column B for unique values and copy them to the temporary worksheet
    rngData.Columns(2).AdvancedFilter _
        Action:=xlFilterCopy, _
        CriteriaRange:="", _
        CopyToRange:=wksTemp.Range("A1"), _
    'Set the range for the unique values from the temporary worksheet
    With wksTemp
        Set rngUniqueVals = .Range("A2", .Cells(.Rows.Count, "A").End(xlUp))
    End With
    'Loop through each unique value
    For Each rngCell In rngUniqueVals
        'Filter for the current unique value
        rngData.AutoFilter Field:=2, Criteria1:="=" & _
            Replace(Replace(Replace(rngCell.Value, "~", "~~"), "*", "~*"), _
                "?", "~?")
        'For versions of Excel prior to 2010, check for the SpecialCells limit
        If Val(Application.Version) < 14 Then
            CellCount = 0
            On Error Resume Next
            CellCount = rngData.Columns(1) _
            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"
                bAborted = True
                Exit For
            End If
        End If
        'Create a new workbook with one worksheet in which to copy the data
        Set wkbDest = Workbooks.Add(xlWBATWorksheet)
        'Set the destination worksheet
        Set wksDest = wkbDest.Worksheets(1)
        'Copy the filtered data to the destination worksheet
        With wksDest.Range("A1")
            .PasteSpecial Paste:=8  'column width for Excel 2000 and later
            .PasteSpecial Paste:=xlPasteValues
            .PasteSpecial Paste:=xlPasteFormats
        End With
        'Define SaveAs filename for the 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 stamp to the filename
        If Len(Dir(strDestPath & strSaveAsFilename)) > 0 Then
            strSaveAsFilename = Replace(strSaveAsFilename, strFileExt, _
                " " & Format(Now, "yyyy-mm-dd hh-mm-ss") & strFileExt)
        End If
        'Save the workbook
        wkbDest.SaveAs _
            Filename:=strDestPath & strSaveAsFilename, _
        'Close the workbook
    Next rngCell
    'Turn off the AutoFilter
    wksSource.AutoFilterMode = False
    'Delete the temporary worksheet
    Application.DisplayAlerts = False
    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 bAborted = False Then
        MsgBox "Completed...", vbInformation
    End If
End Sub

Where to Put the Code

  1. Open the workbook in which to store the code.
  2. Open the Visual Basic Editor (Alt+F11).
  3. Insert a standard module (Insert > Module).
  4. Copy/paste the above code into the module.
  5. Return to Microsoft Excel (Alt+Q).
  6. Save the workbook.

How to Use the Macro

  1. Display the Macro dialog box (Alt+F8).
  2. Click/select the macro called "CreateWorkbooks".
  3. Click/select "Run".

Sample Workbook: Download