Creating workbooks from column value and using for mailmerge

[HappyChick1]

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.

[Admin]

Hi HappyChick1,

Welcome to ExcelFox !!

So in which column do you have the email address ?



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

[HappyChick1]

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

[Admin]

Hi

Download the workbook from http://www.excelfox.com/forum/f12/split-data-into-multiple-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(lngL oopCol))).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_UseExcelObje ctModeltoSendMailPart2_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.

[snb]

This suffices:

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