Creating workbooks from column value and using for mailmerge

[Admin]

Hi

Download the workbook from http://www.excelfox.com/forum/f12/sp...iple-files-33/

Use the template. The codes have some changes. Do the following changes in the codes.

Replace UNIQUEIF code with the following

Dim dic As Object
Function UNIQUE(ByRef Data As Variant)

Dim d, i As Long

d = Data

If dic Is Nothing Then
    Set dic = CreateObject("scripting.dictionary")
        dic.comparemode = 1
End If

With dic
    For i = 2 To UBound(d, 1)
        If Not IsError(d(i, 1)) Then
            If Len(Trim$(d(i, 1))) Then
                dic.Item(Trim$(d(i, 1))) = d(i, 1 + 1) 'Assume the email id is in one col right after the Owner col
            End If
        End If
    Next
    If dic.Count Then UNIQUEIF = dic.keys
End With

End Function

Replace mod_SplitData module with the following

'ExcelFox.com
Const Ttle        As String = "ExcelFox.com"
Sub SplitDataIntoMultipleFiles_V1()
    
    Dim wbkActive           As Workbook
    Dim strFolderPath       As String
    Dim varCols             As Variant
    Dim lngSplitCol         As Long
    Dim strOutPutFolder     As String
    Dim strFileFormat       As String
    Dim wksData             As Worksheet
    Dim blnSplitAllCol      As Boolean
    Dim varUniques          As Variant
    Dim strDataRange        As String
    Dim rngData             As Range
    Dim lngLoop             As Long
    Dim lngLoopCol          As Long
    Dim rngToCopy           As Range
    Dim wbkNewFile          As Workbook
    Dim i                   As Long
    Dim lngFileFormatNum    As Long
    Dim strFileName         As String
    
    On Error Resume Next
    Set wbkActive = ThisWorkbook
    Set wksData = wbkActive.Worksheets(CStr(Range("wksName")))
    If Err.Number <> 0 Then
        MsgBox "Sheet name '" & Range("wksName").Text & "' not found", vbCritical, Ttle
        Err.Clear
        Exit Sub
    End If
    strFolderPath = wbkActive.Path & Application.PathSeparator
    If Len(Range("DataCols")) Then
        varCols = Split(Range("DataCols").Value, ",")
    Else
        blnSplitAllCol = True
    End If
    If Len(Range("SplitCol").Value) = 0 Then
        MsgBox "Column to Split must not be empty", vbCritical, Ttle
        Err.Clear
        Exit Sub
    End If
    lngSplitCol = CLng(Range("SplitCol").Value)
    
    If Right$(Range("OutputFolderPath"), 1) <> "\" Then
        strOutPutFolder = Range("OutputFolderPath") & "\"
    End If
    
    If Not CBool(Len(Dir(strOutPutFolder, vbDirectory))) Then
        strOutPutFolder = strFolderPath
    End If
    
    strFileFormat = IIf(Len(Range("OutputFileFormat").Text), Range("OutputFileFormat").Text, ".CSV")
    
    If Len(Range("DataRange")) = 0 Then
        strDataRange = wksData.UsedRange.Address
    Else
        strDataRange = Range("DataRange")
    End If
    
    Set rngData = Application.Intersect(wksData.UsedRange, wksData.Range(strDataRange))
    
    varUniques = UNIQUE(rngData.Columns(lngSplitCol))
    
    With Application
        .ScreenUpdating = 0
        .DisplayAlerts = 0
    End With
    
    If IsArray(varUniques) Then
        Select Case CLng(Application.Version)
            Case Is < 12
                If UCase$(strFileFormat) = ".XLS" Then
                    lngFileFormatNum = -4143
                ElseIf UCase$(strFileFormat) = ".CSV" Then
                    lngFileFormatNum = 6
                End If
            Case Else
                If UCase$(strFileFormat) = ".XLS" Then
                    lngFileFormatNum = 56
                ElseIf UCase$(strFileFormat) = ".CSV" Then
                    lngFileFormatNum = 6
                ElseIf UCase$(strFileFormat) = ".XLSX" Then
                    lngFileFormatNum = 51
                End If
        End Select
        On Error GoTo Xit
        With rngData
            For lngLoop = LBound(varUniques) To UBound(varUniques)
                Application.StatusBar = "Processing " & lngLoop & " of " & UBound(varUniques)
                If .Parent.FilterMode Then .Parent.ShowAllData
                .AutoFilter lngSplitCol, varUniques(lngLoop)
                Set rngToCopy = Nothing
                Set rngToCopy = .Resize(.Rows.Count, .Columns.Count).SpecialCells(12)
                If Not rngToCopy Is Nothing Then
                    Set wbkNewFile = Workbooks.Add(-4167)
                    rngToCopy.Copy wbkNewFile.Worksheets(1).Range("a1")
                    If Not blnSplitAllCol Then
                        For lngLoopCol = UBound(varCols) To 0 Step -1
                            wbkNewFile.Worksheets(1).Columns(CLng(varCols(lngLoopCol))).Delete
                        Next
                    End If
                    wbkNewFile.SaveAs strOutPutFolder & varUniques(lngLoop) & strFileFormat, lngFileFormatNum
                    strFileName = wbkNewFile.FullName
                    wbkNewFile.Close
                    SendMessage strTo:=dic.Item(varUniques(lngLoop)), strSubject:="Your Subject", strAttachmentPath:=strFileName
                    Set wbkNewFile = Nothing
                End If
            Next
            .AutoFilter
            MsgBox "Done !!", vbInformation, Ttle
        End With
    End If
Xit:
    With Application
        .StatusBar = False
        .ScreenUpdating = 1
        .DisplayAlerts = 1
    End With
    If Not wbkNewFile Is Nothing Then
        wbkNewFile.Close 0
        Set wbkNewFile = Nothing
    End If
    
End Sub

Add another module and insert the following code.

Option Explicit

'Ensure that you select the Microsoft Outlook X.0 Object Library in the references
'Outlook needs to be loaded, and account logged in

Sub SendMessage(strTo As String, Optional strCC As String, Optional strBCC As String, Optional strSubject As String, Optional strMessage As String, Optional strAttachmentPath As String, Optional rngToCopy As Range, Optional blnShowEmailBodyWithoutSending As Boolean = False)

    Dim objOutlook As Outlook.Application
    Dim objOutlookMsg As Outlook.MailItem
    Dim objOutlookRecip As Outlook.Recipient
    Dim objOutlookAttach As Outlook.Attachment

    If Trim(strTo) & Trim(strCC) & Trim(strBCC) = "" Then
        MsgBox "Please provide a mailing address!", vbInformation + vbOKOnly, "Missing mail information"
        Exit Sub
    End If
    ' Create the Outlook session.
    On Error Resume Next
    Set objOutlook = GetObject(, "Outlook.Application")
    Err.Clear: On Error GoTo -1: On Error GoTo 0
    If objOutlook Is Nothing Then
        Set objOutlook = New Outlook.Application
    End If

    ' Create the message.
    Set objOutlookMsg = objOutlook.CreateItem(olMailItem)

    With objOutlookMsg
        ' Add the To recipient(s) to the message.
        If Trim(strTo) <> "" Then
            Set objOutlookRecip = .Recipients.Add(strTo)
            objOutlookRecip.Type = olTo
        End If
        
        ' Add the CC recipient(s) to the message.
        If Trim(strCC) <> "" Then
            Set objOutlookRecip = .Recipients.Add(strCC)
            objOutlookRecip.Type = olCC
        End If

       ' Add the BCC recipient(s) to the message.
       If Trim(strBCC) <> "" Then
            Set objOutlookRecip = .Recipients.Add(strBCC)
            objOutlookRecip.Type = olBCC
        End If

       ' Set the Subject, Body, and Importance of the message.
       If strSubject = "" Then
            strSubject = "This is an Automation test with Microsoft Outlook"
       End If
       .Subject = strSubject
       If strMessage = "" Then
            strMessage = "This is the body of the message." & vbCrLf & vbCrLf
       End If
       .Importance = olImportanceHigh  'High importance
       If Not strMessage = "" Then
        .Body = strMessage & vbCrLf & vbCrLf
       End If
       If Not rngToCopy Is Nothing Then
        .HTMLBody = .Body & RangetoHTML(rngToCopy)
       End If

       ' Add attachments to the message.
       If Not IsMissing(strAttachmentPath) Then
            If Len(Dir(strAttachmentPath)) <> 0 Then
                Set objOutlookAttach = .Attachments.Add(strAttachmentPath)
            Else
                MsgBox "Unable to find the specified attachment. Sending mail anyway."
            End If
       End If

       ' Resolve each Recipient's name.
       For Each objOutlookRecip In .Recipients
           objOutlookRecip.Resolve
       Next

       ' Should we display the message before sending?
       If blnShowEmailBodyWithoutSending Then
           .Display
       Else
           .Save
           .Send
       End If
    End With
    
    Set objOutlook = Nothing
    Set objOutlookMsg = Nothing
    Set objOutlookAttach = Nothing
    Set objOutlookRecip = Nothing
    
End Sub

'http://msdn.microsoft.com/en-us/library/ff519602(v=office.11).aspx#odc_office_UseExcelObjectModeltoSendMailPart2_MailingRangeSelectionBody
Function RangetoHTML(rng As Range)

' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
    ' Copy the range and create a workbook to receive the data.
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
 
    ' Publish the sheet to an .htm file.
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
 
    ' Read all data from the .htm file into the RangetoHTML subroutine.
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
    ' Close TempWB.
    TempWB.Close savechanges:=False
 
    ' Delete the htm file.
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
    
End Function

Note: Add the Microsoft Outlook reference xx.x via Tools > References

It's not tested, hope this should work. Post if any issues.