Do these 3 things before closing this tab:
1Repair Windows errors before they cause bigger problems2Scan for outdated or missing drivers - takes under a minute3Clear out junk files and repair common Windows errorsSome links on this page are affiliate links: if you buy through them we may earn a commission, at no extra cost to you.
Use Excel desktop VBA with classic Outlook automation. The macro below lets you select a grouping column, creates one .xlsx workbook for each distinct nonblank value, finds the matching email address, attaches the completed file, and saves an Outlook draft for review. It never calls .Send.
This is a desktop workflow for a macro-enabled controller workbook. It is not a solution for Excel for the web or browser-only Outlook.
What the macro does
It splits rows, not arbitrary worksheets. For example, selecting Vendor ID in a purchase-order table creates one workbook for L0056T, one for T0074T, and so on. Each output contains the header and only that vendor’s rows.
Quick wins for a faster PC:
Clear out junk files and repair common Windows errorsFree Scan →Fix the driver behind crashes, sound loss and screen glitchesFind Drivers →Repair Windows errors before they cause bigger problemsFix Now →Every group is checked for email consistency. A draft is created only when the group has one distinct, nonblank address. Conflicting or missing addresses are logged instead of being silently guessed.
#1 Best Overall
Prepare the controller workbook
- Put the source data on a sheet named
Data, with headers in row 1 and records below. - Include a grouping column and an email column (for example,
Vendor IDandEmail address). - Save the controller as
.xlsm;.xlsxcannot retain VBA. - On Windows Excel, enable Developer through File > Options > Customize Ribbon. Open Developer > Visual Basic, choose Insert > Module, and paste the code.
- Test with a copy containing only a few groups. Enable macros only when you trust and understand the code.
Complete VBA macro
Select any single cell in the grouping column before running SplitAndDraft. The email column is located by its header text; change EMAIL_HEADER if necessary.
Option Explicit
Private Const DATA_SHEET As String = "Data"
Private Const EMAIL_HEADER As String = "Email address"
Private Const OUTPUT_SUBFOLDER As String = "Split output"
Private Const SUBJECT_TEMPLATE As String = "Records for {GROUP} - {DATE}"
Private Const BODY_TEMPLATE As String = "Hello," & vbCrLf & vbCrLf & _
"Please find attached the records for {GROUP}." & vbCrLf & _
"This message was generated from the master workbook." & vbCrLf & vbCrLf & "Regards"
Public Sub SplitAndDraft()
Dim src As Worksheet, pick As Range, emailCol As Long, splitCol As Long
Dim lastRow As Long, lastCol As Long, r As Long, key As String
Dim groups As Object, emails As Object, rows As Collection
Dim outDir As String, groupKey As Variant, path As String, recipient As String
Dim wbOut As Workbook, wsOut As Worksheet, i As Long, outRow As Long
Dim olApp As Object, mail As Object, made As Long, skipped As Long
Dim stamp As String, fileName As String
On Error GoTo FatalError
Set src = ThisWorkbook.Worksheets(DATA_SHEET)
If ActiveSheet Is Not src Then src.Activate
Set pick = Application.InputBox("Select one cell in the column used for grouping:", _
"Split column", Type:=8)
If pick Is Nothing Then Exit Sub
If pick.Cells.CountLarge <> 1 Or pick.Row < 2 Or pick.Column > src.UsedRange.Columns(src.UsedRange.Columns.Count).Column Then
MsgBox "Select one data cell on the Data sheet.", vbExclamation: Exit Sub
End If
splitCol = pick.Column
emailCol = HeaderColumn(src, EMAIL_HEADER)
If emailCol = 0 Then MsgBox "Header not found: " & EMAIL_HEADER, vbCritical: Exit Sub
lastRow = src.Cells(src.Rows.Count, splitCol).End(xlUp).Row
lastCol = src.Cells(1, src.Columns.Count).End(xlToLeft).Column
If lastRow < 2 Then MsgBox "No data rows were found.", vbExclamation: Exit Sub
Set groups = CreateObject("Scripting.Dictionary")
groups.CompareMode = vbTextCompare
Set emails = CreateObject("Scripting.Dictionary")
emails.CompareMode = vbTextCompare
For r = 2 To lastRow
key = Trim$(CStr(src.Cells(r, splitCol).Value2))
If Len(key) = 0 Then GoTo NextRow
If Not groups.Exists(key) Then Set groups(key) = New Collection
groups(key).Add r
AddEmail emails, key, Trim$(CStr(src.Cells(r, emailCol).Value2))
NextRow:
Next r
outDir = ThisWorkbook.Path & Application.PathSeparator & OUTPUT_SUBFOLDER
If Dir(outDir, vbDirectory) = vbNullString Then MkDir outDir
stamp = Format$(Date, "yyyy-mm-dd")
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
On Error GoTo FatalError
For Each groupKey In groups.Keys
Set rows = groups(groupKey)
fileName = SafeName(BaseName(ThisWorkbook.Name) & "_" & _
CStr(src.Cells(1, splitCol).Value) & "_" & CStr(groupKey) & "_" & stamp) & ".xlsx"
path = outDir & Application.PathSeparator & fileName
If Len(Dir(path)) > 0 Then
skipped = skipped + 1
GoTo NextGroup
End If
Set wbOut = Workbooks.Add(xlWBATWorksheet)
Set wsOut = wbOut.Worksheets(1)
wsOut.Name = "Data"
src.Range(src.Cells(1, 1), src.Cells(1, lastCol)).Copy wsOut.Cells(1, 1)
outRow = 2
For i = 1 To rows.Count
src.Range(src.Cells(rows(i), 1), src.Cells(rows(i), lastCol)).Copy wsOut.Cells(outRow, 1)
outRow = outRow + 1
Next i
wsOut.Columns.AutoFit
Application.DisplayAlerts = False
wbOut.SaveAs Filename:=path, FileFormat:=xlOpenXMLWorkbook
wbOut.Close SaveChanges:=False
Application.DisplayAlerts = True
recipient = GroupEmail(emails, CStr(groupKey))
If Len(recipient) = 0 Or InStr(1, recipient, "@", vbTextCompare) = 0 Then
skipped = skipped + 1
GoTo NextGroup
End If
If olApp Is Nothing Then GoTo NextGroup
Set mail = olApp.CreateItem(0)
mail.To = recipient
mail.Subject = ReplaceTokens(SUBJECT_TEMPLATE, CStr(groupKey), fileName, stamp, rows.Count)
mail.Body = ReplaceTokens(BODY_TEMPLATE, CStr(groupKey), fileName, stamp, rows.Count)
mail.Save
mail.Attachments.Add path, 1
mail.Save
made = made + 1
NextGroup:
Set mail = Nothing
Set wbOut = Nothing
Next groupKey
MsgBox groups.Count & " groups found." & vbCrLf & made & " Outlook drafts created." & vbCrLf & _
skipped & " groups skipped or requiring attention." & vbCrLf & "Output: " & outDir, vbInformation
Exit Sub
FatalError:
Application.DisplayAlerts = True
If Not wbOut Is Nothing Then wbOut.Close SaveChanges:=False
MsgBox "The files already created remain in the output folder." & vbCrLf & Err.Description, vbCritical
End Sub
Private Function HeaderColumn(ws As Worksheet, headerText As String) As Long
Dim c As Range
Set c = ws.Rows(1).Find(headerText, LookAt:=xlWhole, LookIn:=xlValues, MatchCase:=False)
If Not c Is Nothing Then HeaderColumn = c.Column
End Function
Private Sub AddEmail(dict As Object, k As String, address As String)
If Len(address) = 0 Then Exit Sub
If Not dict.Exists(k) Then dict.Add k, address ElseIf InStr(1, ";" & dict(k) & ";", ";" & address & ";", vbTextCompare) = 0 Then dict(k) = dict(k) & ";" & address
End Sub
Private Function GroupEmail(dict As Object, k As String) As String
If dict.Exists(k) Then
If InStr(dict(k), ";") = 0 Then GroupEmail = dict(k)
End If
End Function
Private Function SafeName(s As String) As String
Dim bad, x
bad = Array("\", "/", ":", "*", "?", Chr$(34), "<", ">", "|")
For Each x In bad: s = Replace(s, x, "_"): Next
s = Replace(Replace(s, vbCr, "_"), vbLf, "_")
If Len(s) > 150 Then s = Left$(s, 150)
If UCase$(s) = "CON" Or UCase$(s) = "PRN" Or UCase$(s) = "AUX" Or UCase$(s) = "NUL" Then s = "_" & s
SafeName = s
End Function
Private Function BaseName(s As String) As String
BaseName = Left$(s, InStrRev(s, ".") - 1)
End Function
Private Function ReplaceTokens(t As String, g As String, f As String, d As String, n As Long) As String
t = Replace(t, "{GROUP}", g): t = Replace(t, "{FILE}", f)
t = Replace(t, "{DATE}", d): t = Replace(t, "{COUNT}", CStr(n))
ReplaceTokens = t
End FunctionImportant behavior and customization
- Blank grouping values: They are skipped. Change the loop if you prefer an
Unassignedworkbook. - Email conflicts: More than one distinct address prevents a draft. Correct the source data or implement an explicit business rule.
- Existing files: The sample skips them. Add a sequence suffix or an overwrite prompt if required.
- Formulas: The sample copies formulas. If they reference the master workbook, copy values instead (for example, assign
.Value2) to avoid broken external links. - Formatting and filters: Headers, cell contents, and basic widths are copied. Hidden rows are still processed; use an explicit visible-row rule if that is required.
- Subject and body: Edit the constants or move them to a Settings sheet. Supported tokens are
{GROUP},{FILE},{DATE}, and{COUNT}. - Output format: Outputs are ordinary
.xlsxfiles. Keep VBA in the controller.xlsm.
Why drafts are saved instead of sent
MailItem.Save stores the new message in Outlook’s default folder for that item type, normally Drafts. The macro saves once, adds the attachment using its full local path, and saves again. The output workbook is closed before Outlook attaches it, reducing file-lock problems.
Rank #2
Do not replace the final mail.Save with mail.Send unless you deliberately want immediate delivery. .Send can use Outlook’s default account; multiple-account workflows should explicitly set SendUsingAccount and should be tested separately.
Troubleshooting
| Symptom | What to check |
|---|---|
| Outlook drafts are not created | Classic Outlook must be installed, configured, and available to COM automation. New Outlook, web Outlook, policy restrictions, or security prompts may not support this VBA path. |
| “Header not found” | Make the email header exactly match EMAIL_HEADER, including spelling and spaces. |
| Files exist but no drafts | Inspect missing or conflicting addresses. The macro intentionally creates the workbook but skips an unsafe recipient. |
| Permission denied | Choose a writable local output folder and close any workbook with the same name. |
| Broken formulas | Convert copied formulas to values, or rewrite references for the new workbook. |
| Macro will not run | Save as .xlsm, place the file in a trusted location, and review Excel’s macro security settings. |
When another tool is better
VBA is the practical choice for a local, one-button process that must leave messages in classic Outlook Drafts. Power Query is useful for preparing grouped data but does not by itself create thousands of workbooks and drafts. Office Scripts and Power Automate are better for OneDrive/SharePoint, scheduled or unattended workflows; they generally require a cloud design using files, connectors, and attachment content rather than classic Outlook’s local draft model.
Independent reader supportYour contribution helps us test, update, and keep practical guides available for everyone.Run-safety checklist
- Back up the master workbook and test on a small copy.
- Confirm the selected grouping column and email header.
- Verify the output folder is writable and has enough space.
- Check that the macro contains no
.Sendcall. - Review every generated file and Outlook draft before sending.
- Keep an exception list for blank, malformed, or conflicting email addresses.
Microsoft references: Attachments.Add, MailItem.Save, and MailItem.Send.
Quick Recap
Rank #4
Product prices and availability are accurate as of the date/time indicated and are subject to change. Any price and availability information displayed on Amazon at the time of purchase will apply.
