Creating workbooks from column value and using for mailmerge

Good afternoon,

I was after some assistance, for which I've already searched your forum.

I want to be able to email the person listed in the 'Owner' column with a spreadsheet attached that lists only the items where they are listed as owner. I've looked at a data split macro on here, but it had trouble when it got to the UniqueIF code and I'm beginner so wasn't sure how to get around it.

Preference is for this to occur via macro rather than downloading a program.

Any assistance would be appreciated.

Hi HappyChick1,

Welcome to ExcelFox !!

So in which column do you have the email address ?



https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

Thankyou for the welcome. And good point! My apologies for that oversight.
The email address will go in column I.

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

Code:

---

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

Code:

---

'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.

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.

This suffices:

Code:

---

Sub M_snb()
    Sheets.Add.Name = "transport"
   
    For Each it In Filter([transpose(if(countif(offset(tempquery!H2,,,row(H2:H10)-1),tempquery!H2:H10)=1,tempquery!H2:H10))], False, False)
        Sheets("transport").UsedRange.ClearContents
        With Sheets("tempQuery").Cells(1).CurrentRegion
            .AutoFilter 8, it
            c01 = Sheets("tempquery").Columns(9).SpecialCells(12)(2)
            .Copy Sheets("transport").Cells(1)
            .AutoFilter
        End With
       
        Sheets("transport").Copy
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & it & ".xlsx", 56
        ActiveWorkbook.Close
       
        With CreateObject("outlook.application").createitem(0)
            .to = c01
            .Subject = "new file"
            .attachments.Add ThisWorkbook.Path & "\" & it & ".xlsx"
            .send
        End With
    Next
End Sub

---