Visit my Youtube Channel
Split and Merge Files
Note: This webpage is designed to accompany the Youtube video posted above. The video offers detailed explanation on all topics; while this webpage will serve as a repository for the code presented in the video.
Each code block covered in the video is given below.
Learn how to Split and Merge files using Excel VBA. These are two separate workflows. For the Split section, we will check out how to split a report into multiple Excel files. And for the Merge section, we will learn how to merge data from a bunch of Excel files into a single dataset.
But, that’s not all. Because VBA is a super-awesome tool to automate workflows, I am going to show some extra goodies as well. For the Split section, I will share the code to create individual files and then, email them out within the same macro flow. And for the Merge part, we will check out the code to download attachments directly from Outlook onto our local drive and then, merge those files together, all within the same code.
Split Macro
Option Explicit
Public Const folderPath = "C:\Youtube\Current\04 Merge and Split Reports\Demo\Invoices"
Sub SplitFiles()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
wsRough.Cells.Clear
wsRough.Range("A1") = "Sales Person"
wsRough.Range("D1") = "Sales Person"
Dim rngList As Range, rngCriteria As Range, rngCopyTo As Range
Set rngList = wsSplit.Range("A1").CurrentRegion
Set rngCopyTo = wsRough.Range("A1:A1")
rngList.AdvancedFilter xlFilterCopy, , rngCopyTo, Unique:=True
Dim lrow As Long
lrow = wsRough.Range("A1").CurrentRegion.Rows.Count
Dim i As Long
Dim wb As Workbook, ws As Worksheet, NewRngCopyTo As Range, sSalesPerson As String, sFileName As String
For i = 2 To lrow
sSalesPerson = wsRough.Range("A" & i).Value
wsRough.Range("D2").Value = ""
wsRough.Range("D2").Value = sSalesPerson
Set rngCriteria = wsRough.Range("D1:D2")
Set wb = Workbooks.Add
Set ws = wb.Sheets("Sheet1")
rngList.Rows(1).Copy ws.Range("A1")
Set NewRngCopyTo = ws.Range("A1").CurrentRegion
rngList.AdvancedFilter xlFilterCopy, rngCriteria, NewRngCopyTo
sFileName = folderPath & "\" & sSalesPerson
wb.SaveAs sFileName, FileFormat:=xlWorkbookDefault
wb.Close savechanges:=False
Set rngCriteria = Nothing
Set wb = Nothing
Set ws = Nothing
Set NewRngCopyTo = Nothing
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Merge Macro
Option Explicit
Public Const folderPath = "C:\Youtube\Current\04 Merge and Split Reports\Demo\Invoices"
Sub MergeFiles()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
wsMerge.Cells.Clear
Dim lrow As Long
Dim wb As Workbook
Dim fileCount As Long
fileCount = 0
Dim fileName As String
fileName = Dir(folderPath & "\" & "*.xlsx")
Do While fileName <> ""
Set wb = Workbooks.Open(folderPath & "\" & fileName)
If fileCount = 0 Then
wb.Sheets("Sheet1").Range("a1").CurrentRegion.Copy wsMerge.Range("A1")
fileCount = 1
Else
wb.Sheets("Sheet1").Range("a1").CurrentRegion.Offset(1, 0).Resize _
(wb.Sheets("Sheet1").Range("a1").CurrentRegion.Rows.Count - 1) _
.Copy wsMerge.Range("A" & lrow)
End If
wb.Close savechanges:=False
Set wb = Nothing
lrow = wsMerge.Range("a1").CurrentRegion.Rows.Count + 1
fileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Split and Email Macro
Option Explicit
Sub SplitAndEmail()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
wsRough.Cells.Clear
wsRough.Range("A1") = "Sales Person"
wsRough.Range("D1") = "Sales Person"
Dim rngList As Range, rngCriteria As Range, rngCopyTo As Range
Set rngList = wsSplit.Range("A1").CurrentRegion
Set rngCopyTo = wsRough.Range("A1:A1")
rngList.AdvancedFilter xlFilterCopy, , rngCopyTo, Unique:=True
Dim lrow As Long
lrow = wsRough.Range("A1").CurrentRegion.Rows.Count
Dim i As Long
Dim wb As Workbook, ws As Worksheet, NewRngCopyTo As Range, sSalesPerson As String, sFileName As String
'New Start
Dim sEmailId As String
'New End
For i = 2 To lrow
sSalesPerson = wsRough.Range("A" & i).Value
wsRough.Range("D2").Value = ""
wsRough.Range("D2").Value = sSalesPerson
Set rngCriteria = wsRough.Range("D1:D2")
Set wb = Workbooks.Add
Set ws = wb.Sheets("Sheet1")
rngList.Rows(1).Copy ws.Range("A1")
Set NewRngCopyTo = ws.Range("A1").CurrentRegion
rngList.AdvancedFilter xlFilterCopy, rngCriteria, NewRngCopyTo
sFileName = folderPath & "\" & sSalesPerson
wb.SaveAs sFileName, FileFormat:=xlWorkbookDefault
wb.Close savechanges:=False
'New Start
sEmailId = FindEmailId(sSalesPerson)
Call SendEmail(sEmailId, sFileName)
'New End
Set rngCriteria = Nothing
Set NewRngCopyTo = Nothing
Set wb = Nothing
Set ws = Nothing
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Support Macros
Function FindEmailId(sSalesPerson As String) As String
Dim rngSearch As Range, rngResponse As Range
Set rngSearch = wsEmail.Range("A1").CurrentRegion
On Error Resume Next
Set rngResponse = rngSearch.Find( _
What:=sSalesPerson).Offset(0, 1)
sSalesPerson = rngResponse.Value
On Error GoTo 0
FindEmailId = sSalesPerson
End Function
Sub SendEmail(sEmailId As String, sFileName As String)
sFileName = sFileName & ".xlsx"
' Connect to Outlook
Dim oApp As Object
Set oApp = CreateObject("Outlook.Application")
' Create an email Object
Dim oMail As Object
Set oMail = oApp.CreateItem(0)
With oMail
.To = sEmailId
.CC = ""
.BCC = ""
.Subject = "Outstanding Invoices"
.HTMLBody = "Hi There,<br>" & _
"Please review the attached invoices.<br>" & _
"Regards,"
.Attachments.Add sFileName
.Display
.Send
End With
End Sub
Download and Merge
Sub DownloadAndMerge()
Call ReadOutlookEmails
Call MergeFiles
End Sub
Use Previous Merge Macro. Merge Support Macro is below.
Public Sub ReadOutlookEmails()
Dim oApp As Object
Set oApp = CreateObject("Outlook.Application")
Dim oName As Object
Set oName = oApp.GetNamespace("MAPI")
'
Dim oFolder As Object
Set oFolder = oName.GetDefaultFolder(6).Folders("Invoices")
Dim oMail As Object
Dim oAttach As Object
Dim sAttachName As String
For Each oMail In oFolder.Items
For Each oAttach In oMail.Attachments
sAttachName = oAttach.fileName
sAttachName = folderPath & "\" & sAttachName
oAttach.SaveAsFile sAttachName
Next oAttach
Next oMail
End Sub