Results 1 to 5 of 5

Thread: Creating workbooks from column value and using for mailmerge

Hybrid View

Previous Post Previous Post   Next Post Next Post
  1. #1
    Junior Member
    Join Date
    Nov 2012
    Posts
    2
    Rep Power
    0

    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.
    Attached Files Attached Files

  2. #2
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,123
    Rep Power
    10
    Hi HappyChick1,

    Welcome to ExcelFox !!

    So in which column do you have the email address ?



    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    Last edited by DocAElstein; 06-10-2023 at 04:26 PM.
    Cheers !

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

  3. #3
    Junior Member
    Join Date
    Nov 2012
    Posts
    2
    Rep Power
    0
    Thankyou for the welcome. And good point! My apologies for that oversight.
    The email address will go in column I.

  4. #4
    Administrator Admin's Avatar
    Join Date
    Mar 2011
    Posts
    1,123
    Rep Power
    10
    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.
    Cheers !

    Excel Range to BBCode Table
    Use Social Networking Tools If You Like the Answers !

    Message to Cross Posters

    @ Home - Office 2010/2013/2016 on Win 10 (64 bit); @ Work - Office 2016 on Win 10 (64 bit)

  5. #5
    Senior Member
    Join Date
    Jun 2012
    Posts
    337
    Rep Power
    13
    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

Similar Threads

  1. Creating Powerpoint Slides: Rules
    By Transformer in forum Powerpoint Help
    Replies: 0
    Last Post: 05-17-2013, 08:41 PM
  2. Replies: 7
    Last Post: 05-09-2013, 11:16 PM
  3. Creating drop-down function in excel
    By Jorrg1 in forum Excel Help
    Replies: 4
    Last Post: 01-09-2013, 01:45 PM
  4. Replies: 3
    Last Post: 05-14-2012, 11:30 AM
  5. Finding Credit and Debit Data and Creating Pivot
    By Prabhu in forum Excel Help
    Replies: 10
    Last Post: 01-29-2012, 11:03 PM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •