.SaveAs filename:=Path & fname & "_" & Terminal & ".xls"Sorry for the delay in reply....it's 2013
Sub Main()
Dim fn As String, p As String
Dim ws As Worksheet, wt As Worksheet
Dim cMode As Integer, c As Range, a, e
'Set and create desktop Template folder/path if needed.
p = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Template\"
If Dir(p, vbDirectory) = "" Then MkDir p
'Speed things along a bit...
Application.ScreenUpdating = False
Application.EnableEvents = False
cMode = Application.Calculation
Application.Calculation = xlCalculationManual
'Set source worksheet
Set ws = ActiveSheet
With ws
Set c = .Range("G11")
'Set a = unique values in column G11 (c) and down.
a = UniqueArrayByDict(.Range(c.Offset(1), _
.Cells(.Rows.Count, c.Column).End(xlUp)).Value)
.AutoFilterMode = False
'Iterate each element in array a for unique values in filters field c.
For Each e In a
c.AutoFilter field:=7, Criteria1:=e
.Range("B3").Value = e
.UsedRange.SpecialCells(xlCellTypeVisible).Copy
Set wt = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
wt.Paste
'???? fn built right?
fn = p & e & ".xlsx"
Debug.Print fn
'Delete xlsx file if it exists.
If Dir(fn) <> "" Then Kill fn
wt.SaveAs fn, xlOpenXMLWorkbook
wt.Parent.Close False
Next e
'???? Reset B3 value?
.Range("B3").Value = ""
.AutoFilterMode = False 'Turn off
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = cMode
End Sub
'Early Binding method requires Reference: MicroSoft Scripting Runtime, scrrun.dll
Function UniqueArrayByDict(Array1d As Variant, Optional compareMethod As Integer = 0) As Variant
Dim dic As Object 'Late Binding method - Requires no Reference
Set dic = CreateObject("Scripting.Dictionary") 'Late or Early Binding method
'Dim dic As Dictionary 'Early Binding method
'Set dic = New Dictionary 'Early Binding Method
Dim e As Variant
dic.CompareMode = compareMethod
'BinaryCompare=0
'TextCompare=1
'DatabaseCompare=2
For Each e In Array1d
If Not dic.Exists(e) Then dic.Add e, Nothing
Next e
UniqueArrayByDict = dic.Keys
End Function
One thing you can add is while saving file name it should be Line_POL (ex: Asiats_UQR)
Sub Obj1()
Dim fn As String, p As String
Dim ws As Worksheet, wt As Worksheet
Dim cMode As Integer, c As Range, r As Range
Dim a, e
'Set and create desktop Template folder/path if needed.
p = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Template\"
If Dir(p, vbDirectory) = "" Then MkDir p
'Speed things along a bit...
Application.ScreenUpdating = False
Application.EnableEvents = False
cMode = Application.Calculation
Application.Calculation = xlCalculationManual
'Set source worksheet
Set ws = Worksheets("SLOT MSG")
With ws
Set c = .Range("G11")
'Set a = unique values in column G11 (c) and down.
a = UniqueArrayByDict(.Range(c.Offset(1), _
.Cells(.Rows.Count, c.Column).End(xlUp)).Value)
.AutoFilterMode = False
'Iterate each element in array a for unique values in filters field c.
For Each e In a
c.AutoFilter field:=7, Criteria1:=e
Set r = .UsedRange.SpecialCells(xlCellTypeVisible)
r.Copy
Set wt = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
wt.Paste
'Set B3 in both wt and ThisWorkbook
wt.Range("B3").Formula = "=D12"
.Range("B3").Value = wt.Range("B3").Value
'Basefilename=Line_POL.xlsx, e.g. Asiats_UQR.xlsx
fn = p & e & "_" & .Range("B3").Value & ".xlsx"
'Delete xlsx file if it exists.
If Dir(fn) <> "" Then Kill fn
wt.SaveAs fn, xlOpenXMLWorkbook
wt.Parent.Close False
Next e
'???? Reset B3 value?
.Range("B3").Value = ""
.AutoFilterMode = False 'Turn off
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = cMode
End Sub
'Early Binding method requires Reference: MicroSoft Scripting Runtime, scrrun.dll
Function UniqueArrayByDict(Array1d As Variant, Optional compareMethod As Integer = 0) As Variant
Dim dic As Object 'Late Binding method - Requires no Reference
Set dic = CreateObject("Scripting.Dictionary") 'Late or Early Binding method
'Dim dic As Dictionary 'Early Binding method
'Set dic = New Dictionary 'Early Binding Method
Dim e As Variant
dic.CompareMode = compareMethod
'BinaryCompare=0
'TextCompare=1
'DatabaseCompare=2
For Each e In Array1d
If Not dic.Exists(e) Then dic.Add e, Nothing
Next e
UniqueArrayByDict = dic.Keys
End FunctionSub Obj2()
Dim ws As Worksheet, r As Range, c As Range
Dim p$, fn$, sTo$, sCC$, sSubject$, bPrefix$, bSuffix$
'Tools > References > Microsoft Outlook xx.0 Object Library
Dim olApp As Outlook.Application, olMail As Outlook.MailItem
'Tools > References > Microsoft Word xx.0 Object Library
Dim Word As Document, wr As Word.Range
'Workbooks to add as email attachment
p = CreateObject("WScript.Shell").SpecialFolders("Desktop") _
& "\Template\"
If Dir(p, vbDirectory) = "" Then Exit Sub
bPrefix = "Dear Customer," & vbCrLf & vbCrLf & _
"XXXX xXXXXXX X XXXXXXXXXXX XXXXXXXXXXXX XXXX X XXXXXXXXXXXX XXXXXXXXX" & vbCrLf & _
"XXXX xXXXXXX X XXXXXXXXXXX XXXXXXXXXXXX XXXX X XXXXXXXXXXXX XXXXXXXXX" & vbCrLf & _
"XXXX xXXXXXX X XXXXXXXXXXX XXXXXXXXXXXX XXXX X XXXXXXXXXXXX XXXXXXXXX" & vbCrLf & _
"XXXX xXXXXXX X XXXXXXXXXXX XXXXXXXXXXXX XXXX X XXXXXXXXXXXX XXXXXXXXX" & vbCrLf & _
"XXXX xXXXXXX X XXXXXXXXXXX XXXXXXXXXXXX XXXX X XXXXXXXXXXXX XXXXXXXXX" & vbCrLf & _
vbCrLf & vbCrLf
bSuffix = vbCrLf & vbCrLf & _
"XXXX xXXXXXX X XXXXXXXXXXX XXXXXXXXXXXX XXXX X XXXXXXXXXXXX XXXXXXXXX" & vbCrLf & _
"XXXX xXXXXXX X XXXXXXXXXXX XXXXXXXXXXXX XXXX X XXXXXXXXXXXX XXXXXXXXX" & vbCrLf & _
"XXXX xXXXXXX X XXXXXXXXXXX XXXXXXXXXXXX XXXX X XXXXXXXXXXXX XXXXXXXXX" & vbCrLf & _
"XXXX xXXXXXX X XXXXXXXXXXX XXXXXXXXXXXX XXXX X XXXXXXXXXXXX XXXXXXXXX" & vbCrLf & _
vbCrLf & vbCrLf & vbCrLf & _
"Regards," & vbCrLf & vbCrLf & "Ashish a.Bangera"
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
Set ws = ThisWorkbook.Worksheets("Sheet2Line ")
With ws
Set r = .Range("A2", .Range("A2").End(xlDown))
For Each c In r
fn = Dir(p & c & "_*.xlsx")
'If no file to attach exists, go to next Line item.
If fn = "" Then GoTo NextC
fn = p & fn
sTo = c.Offset(, 1).Value2
sCC = c.Offset(, 2).Value2
If sTo = "" And sCC = "" Then GoTo NextC
sSubject = "ARRIVAL ADVICE- " & .[B1] & _
"_" & .[A1] & " " & .[B2]
With olMail
.Importance = olImportanceNormal
.To = sTo
.CC = sCC
.Subject = sSubject
.Attachments.Add fn
'.GetInspector.Display
Set Word = .GetInspector.WordEditor
'Add Prefix to body.
Word.Content = bPrefix
'Add table to body.
[eTable].Copy
Set wr = Word.Content
wr.Collapse Direction:=wdCollapseEnd
wr.Paste
wr.Collapse Direction:=wdCollapseEnd
wr.Text = bSuffix
Application.CutCopyMode = False
'https://msdn.microsoft.com/en-us/library/microsoft.office.interop.outlook._mailitem.deferreddeliverytime.aspx?cs-save-lang=1&cs-lang=vb#code-snippet-1
'.DeferredDeliveryTime = Now + TimeValue("00:10:00")
.Display
'.Send
End With
NextC:
Next c
End With
Set olMail = Nothing
Set olApp = Nothing
End Sub