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.
Reply With Quote
Bookmarks