Dealing with data (as in statistics, not storage) is a daily job of sysadmins. I love CSV exports but often times I need to separate the data out by a certain column or split into multiple workbooks/files to send to other staff. For instance, there are 22 branch offices where I work and getting the appropriate data to each building from one spreadsheet used to be a daunting task.
The first macro below (SplitToWorksheets) for Microsoft Office Excel allows you to take a worksheet and split it into multiple worksheets based on the column header you define when running it. You can then use the second macro (Split_To_Workbook_and_Email) I have used this macro in Office 2013 and 2016 for many years with great success.
To add the macro to Excel, follow these steps:
Make sure you have the developer tab enabled. If not, see here
On the developer tab, click the Visual Basic button
In the top left pane, expand the VBAProject associated with your workbook. Right click on the Modules folder and insert a new module
Copy and paste the following code into the empty module:
Sub SplitToWorksheets() Dim ColHead As String Dim ColHeadCell As Range Dim iCol As Integer Dim iRow As Long 'row index on Fan Data sheet Dim Lrow As Integer 'row index on individual destination sheet Dim Dsheet As Worksheet 'destination worksheet Dim Fsheet As Worksheet 'fan data worksheet (assumed active) Again: ColHead = InputBox("Enter Column Heading", "Identify Column", [c1].Value) If ColHead = "" Then Exit Sub Set ColHeadCell = Rows(1).Find(ColHead, LookAt:=xlWhole) If ColHeadCell Is Nothing Then MsgBox "Heading not found in row 1" GoTo Again End If Set Fsheet = ActiveSheet iCol = ColHeadCell.Column 'loop through values in selected column For iRow = 2 To Fsheet.Cells(65536, iCol).End(xlUp).Row If Not SheetExists(CStr(Fsheet.Cells(iRow, iCol).Value)) Then Set Dsheet = Worksheets.Add(after:=Worksheets(Worksheets.Count)) Dsheet.Name = CStr(Fsheet.Cells(iRow, iCol).Value) Fsheet.Rows(1).Copy Destination:=Dsheet.Rows(1) Else Set Dsheet = Worksheets(CStr(Fsheet.Cells(iRow, iCol).Value)) End If Lrow = Dsheet.Cells(65536, iCol).End(xlUp).Row Fsheet.Rows(iRow).Copy Destination:=Dsheet.Rows(Lrow + 1) Next iRow End Sub Function SheetExists(SheetId As Variant) As Boolean ' This function checks whether a sheet (can be a worksheet, ' chart sheet, dialog sheet, etc.) exists, and returns ' True if it exists, False otherwise. SheetId can be either ' a sheet name string or an integer number. For example: ' If SheetExists(3) Then Sheets(3).Delete ' deletes the third worksheet in the workbook, if it exists. ' Similarly, ' If SheetExists("Annual Budget") Then Sheets("Annual Budget").Delete ' deletes the sheet named "Annual Budget", if it exists. Dim sh As Object On Error GoTo NoSuch Set sh = Sheets(SheetId) SheetExists = True Exit Function NoSuch: If Err = 9 Then SheetExists = False Else Stop End Function Sub Split_To_Workbook_and_Email() 'Working in 2013/2016 Dim FileExtStr As String Dim FileFormatNum As Long Dim Sourcewb As Workbook Dim Destwb As Workbook Dim sh As Worksheet Dim DateString As String Dim FolderName As String Dim myOutlook As Object Dim myMailItem As Object Dim mySubject As String Dim myPath As String With Application .ScreenUpdating = False .EnableEvents = False .Calculation = xlCalculationManual End With 'Prompt for Email Subject Set otlApp = CreateObject("Outlook.Application") mySubject = InputBox("Subject for Email") 'Copy every sheet from the workbook with this macro Set Sourcewb = ActiveWorkbook 'Create new folder to save the new files in DateString = Format(Now, "yyyy-mm-dd hh-mm-ss") FolderName = "C:\Temp\" & Sourcewb.Name & " " & DateString MkDir FolderName 'Copy every visible sheet to a new workbook For Each sh In Sourcewb.Worksheets 'If the sheet is visible then copy it to a new workbook If sh.Visible = -1 Then sh.Copy 'Set Destwb to the new workbook Set Destwb = ActiveWorkbook 'Determine the Excel version and file extension/format With Destwb If Val(Application.Version) < 12 Then 'You use Excel 97-2003 FileExtStr = ".xls": FileFormatNum = -4143 Else 'You use Excel 2007-2016 If Sourcewb.Name = .Name Then MsgBox "Your answer is NO in the security dialog" GoTo GoToNextSheet Else FileExtStr = ".xlsx": FileFormatNum = 51 End If End If End With 'Change all cells in the worksheet to values if you want If Destwb.Sheets(1).ProtectContents = False Then With Destwb.Sheets(1).UsedRange .Cells.Copy .Cells.PasteSpecial xlPasteValues .Cells(1).Select End With Application.CutCopyMode = False End If 'Save the new workbook, email it, and close it Set otlNewMail = otlApp.CreateItem(olMailItem) With Destwb .SaveAs FolderName _ & "\" & Destwb.Sheets(1).Name & FileExtStr, _ FileFormat:=FileFormatNum End With myPath = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name With Destwb .Close False End With With otlNewMail .Subject = mySubject .Body = " " .Attachments.Add myPath .Display End With Set otlNewMail = Nothing End If GoToNextSheet: Next sh MsgBox "You can find the files in " & FolderName With Application .ScreenUpdating = True .EnableEvents = True .Calculation = xlCalculationAutomatic End With End Sub
By default, it will save the separated workbooks to the C:\Temp folder. To change that, find the line above
FolderName = "C:\Temp\" & Sourcewb.Name & " " & DateStringand change
c:\Temp\to wherever you'd like.
You are now ready to run the macro. Simply run
SplitToWorksheets- it will prompt you to enter the name of the column you'd like to split things up by. Once that finishes, you can run
Split_To_Workbook_and_Email- it will prompt you for the email subject line and then proceed to split each sheet into its own workbook and attach it to a new Outlook email.
Run into any issues? Just leave me a comment below!
Source: Based on macro from Ron Debruin