VBA split file based and send splitted file in separate emails

harmless92

New Member
Joined
Mar 15, 2024
Messages
3
Office Version
  1. 365
Platform
  1. Windows
Hello,
I am trying to build a VBA code to split one source Excel file in several excel files (the "master file"). The master file file contains 2 sheets. The sheet 1 contains the data and the sheet 2 contains a table with 2 columns: columns 1 with the supplier number and column 2 with the email address of the recipient.
The sheet 1 contains the data with several columns with many rows. I need to extract the data of the sheet 1 in as many different excel files as number of supplier number I have in the source file (which is in column A of the source file).
Each excel file generated by the macro should be stored in a folder and each excel file stored in the folder should be named by the "suppliernumber.xlsx". Then in a second step, each excel file should be sent to an email address stored in a sheet 2. As an example, the excel file 30020909.xlsx is referenced in column 1 of the table in sheet 2 of the master file and in the column there is an email address: YYY@YYY.com. So by clicking on the macro the file should be attached and sent to this address email and the same for all files in the folder. My code is not working and I am wondering if you could help or guide me to find a solution ? Thank you in advance.

Sheet 1 data structure and example:
Col A / Col B / Col C / Col D
supplierNumber / Article number / Forecast P1 / Forecast P2
654021 / 707-2001193 / 340000 / 455000
30020909 / 707-2000479 / 43000 / 340000

Sheet data structure and example:
Col A / Col B
supplierNumber / email
654021 / XXX@XXX.fr
30020909 / YYY@YYY.com


My Code:



VBA Code:
Sub SplitAndEmailFiles()
    Dim wsData As Worksheet, wsEmails As Worksheet
    Dim dict As Object, key As Variant
    Dim lastRow As Long, i As Long
    Dim supplierNumber As String, email As String
    Dim wbNew As Workbook
    Dim folderPath As String
    
    Set wsData = ThisWorkbook.Sheets(1) ' Assuming data is in the first sheet
    Set wsEmails = ThisWorkbook.Sheets(2) ' Assuming email addresses are in the second sheet
    Set dict = CreateObject("Scripting.Dictionary")
    folderPath = "C:\Yoplait_Forecast\" ' Change to your folder path
    
    ' Read supplier numbers and their emails into a dictionary
    With wsEmails
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To lastRow ' Assuming row 1 has headers
            dict(.Cells(i, 1).Value) = .Cells(i, 2).Value
        Next i
    End With
    
    ' Create individual files for each supplier number
    With wsData
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 2 To lastRow ' Assuming row 1 has headers
            supplierNumber = .Cells(i, 1).Value
                If dict.exists(supplierNumber) Then
                    email = dict(supplierNumber)
            
            ' Check if the workbook for this supplier already exists, if not, create it
            If Not WorkbookExists(folderPath & supplierNumber & ".xlsx") Then
                Set wbNew = Workbooks.Add
                .Rows(1).Copy Destination:=wbNew.Sheets(1).Rows(1) ' Copy headers
                wbNew.SaveAs fileName:=folderPath & supplierNumber & ".xlsx"
                wbNew.Close SaveChanges:=False
            End If
            
            ' Add data row to the supplier's workbook
            AppendDataRow folderPath & supplierNumber & ".xlsx", .Rows(i)
        Next i
    End With
    
    ' Email the files
    For Each key In dict
        SendEmailWithAttachment dict(key), folderPath & key & ".xlsx", "Subject here", "Body here"
    Next key

End Sub

Function WorkbookExists(fileName As String) As Boolean
    Dim ff As Integer
    On Error Resume Next
    ff = FreeFile()
    Open fileName For Input Lock Read As #ff
    If Err.Number = 0 Then
        WorkbookExists = True
        Close #ff
    Else
        WorkbookExists = False
    End If
    On Error GoTo 0
End Function

Sub AppendDataRow(fileName As String, dataRow As Range)
    Dim wb As Workbook
    Dim ws As Worksheet
    Set wb = Workbooks.Open(fileName)
    Set ws = wb.Sheets(1)
    ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, dataRow.Columns.Count).Value = dataRow.Value
    wb.Close SaveChanges:=True
End Sub

Sub SendEmailWithAttachment(toEmail As String, attachmentPath As String, subjectText As String, bodyText As String)
    Dim outlookApp As Object
    Dim outlookMail As Object
    Set outlookApp = CreateObject("Outlook.Application")
    Set outlookMail = outlookApp.CreateItem(0)
    
    With outlookMail
        .To = toEmail
        .Subject = subjectText
        .Body = bodyText
        .Attachments.Add (attachmentPath)
        .Send
    End With
End Sub
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes

Forum statistics

Threads
1,224,811
Messages
6,181,081
Members
453,021
Latest member
Justyna P

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top