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