bcostin
05-15-2012, 01:24 PM
237238
Hello
I need to create about 100 word reports from an excel "database"
Please help me with speeding up the following code:
'------------------------------------------
' Working 2012-05-15
'------------------------------------------
Option Explicit
Sub WordGenerate()
Dim CL As Range, rdata As Range, filt As Range
Dim UniqueClient As Range, CUniqueClient As Range, Dest As Range
Dim Client As String, RM() As String, TA() As String, TA_Email() As String, TA_Phone() As String
Dim ContractTYPE() As String, Supplier() As String, FundID() As String, FundName() As String, Email() As String
Dim Phone() As String, Mobile() As String, JobTitle() As String, Initials() As String, Surname() As String
Dim i As Integer, j As Integer, k As Integer, y As Integer, Speed As Date
Dim wrdApp As Object, tmpDoc As Object, wrdDoc As Object, WRng As Object, wrdRange As Object
Dim WDoc As String, myDoc As String, x As String, Path As String, t As String, MyName As String
Dim strBar As String
Dim lngLoop As Integer
Application.ScreenUpdating = False
Application.EnableEvents = False
Speed = Now()
With Worksheets("DB")
Set CL = Range(.Range("A1"), .Range("A1").End(xlDown))
Set UniqueClient = .Range("A1").End(xlDown).Offset(5, 0)
CL.AdvancedFilter xlFilterCopy, , UniqueClient, True
Set UniqueClient = Range(UniqueClient.Offset(1, 0), UniqueClient.End(xlDown))
Set rdata = .Range("A1").CurrentRegion
rdata.Sort key1:=.Range("A1"), header:=xlYes
MyName = ThisWorkbook.Path
myDoc = "Fund Purchasing Report - Template.doc"
WDoc = MyName & Application.PathSeparator & myDoc
On Error Resume Next
MkDir MyName & "\Reports as at " & Format(Date, "yyyy-mm-dd")
On Error GoTo 0
i = 1
For Each CUniqueClient In UniqueClient
x = CUniqueClient.Value
lngLoop = UniqueClient.Rows.Count
rdata.AutoFilter field:=1, Criteria1:=x
Set filt = rdata.Offset(1, 0).Resize(rdata.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
Client = filt.Areas(1).Cells(1, "A").Value
j = filt.Areas(1).Rows.Count
i = i + 1
strBar = String(Round(i / lngLoop * 15, 0), ChrW(&H25A0)) & String(15 - Round(15 * i / lngLoop, 0), ChrW(&H25A1))
Application.StatusBar = strBar & Format((i - 1) / lngLoop, " 0%") & " Save report for: " & x
ReDim RM(1 To j)
ReDim TA(1 To j)
ReDim ContractTYPE(1 To j)
ReDim Supplier(1 To j)
ReDim FundID(1 To j)
ReDim FundName(1 To j)
ReDim Email(1 To j)
ReDim Phone(1 To j)
ReDim Mobile(1 To j)
ReDim JobTitle(1 To j)
ReDim Initials(1 To j)
ReDim Surname(1 To j)
ReDim TA_Email(1 To j)
ReDim TA_Phone(1 To j)
For k = 1 To j
Client = filt.Areas(1).Cells(k, "A").Value
RM(k) = filt.Areas(1).Cells(k, "B").Value
TA(k) = filt.Areas(1).Cells(k, "C").Value
ContractTYPE(k) = filt.Areas(1).Cells(k, "E").Value
Supplier(k) = filt.Areas(1).Cells(k, "F").Value
FundID(k) = filt.Areas(1).Cells(k, "H").Value
FundName(k) = filt.Areas(1).Cells(k, "I").Value
Email(k) = filt.Areas(1).Cells(k, "J").Value
Phone(k) = filt.Areas(1).Cells(k, "K").Value
Mobile(k) = filt.Areas(1).Cells(k, "L").Value
JobTitle(k) = filt.Areas(1).Cells(k, "M").Value
Initials(k) = filt.Areas(1).Cells(k, "N").Value
Surname(k) = filt.Areas(1).Cells(k, "O").Value
TA_Email(k) = filt.Areas(1).Cells(k, "P").Value
TA_Phone(k) = filt.Areas(1).Cells(k, "Q").Value
Next k
'-----------------------------------------------------------------------------
On Error Resume Next
For k = 1 To j
MkDir MyName & "\Reports as at " & Format(Date, "yyyy-mm-dd") & Application.PathSeparator & Surname(k)
Next k
On Error GoTo 0
'-----------------------------------------------------------------------------
On Error Resume Next
Set wrdApp = GetObject(, "Word.Application")
If wrdApp Is Nothing Then
' no current word application
Set wrdApp = CreateObject("Word.application")
Set wrdDoc = wrdApp.Documents.Open(WDoc)
wrdApp.Visible = False
Else
' word app running
For Each tmpDoc In wrdApp.Documents
If StrComp(tmpDoc.FullName, WDoc, vbTextCompare) = 0 Then
' this is your doc
Set wrdDoc = tmpDoc
Exit For
End If
Next
If wrdDoc Is Nothing Then
' not open
Set wrdDoc = wrdApp.Documents.Open(WDoc)
End If
End If
'-----------------------------------------------------------------------------
Set wrdRange = wrdDoc
With wrdDoc
wrdApp.Selection.Style = "DocTitle"
wrdApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
wrdApp.Selection.Font.Color = RGB(166, 166, 166) 'Title
wrdApp.Selection.Font.Name = "Georgia"
wrdApp.Selection.Font.Size = 26
wrdApp.Selection.ParagraphFormat.SpaceAfter = 18
wrdApp.Selection.ParagraphFormat.LineSpacingRule = "At least"
wrdApp.Selection.ParagraphFormat.LineSpacing = 13
wrdApp.Selection.TypeText Text:="Trader SRL"
wrdApp.Selection.TypeParagraph
wrdApp.Selection.Font.Color = RGB(51, 51, 153) 'Title
wrdApp.Selection.Font.Name = "Georgia"
wrdApp.Selection.Font.Size = 23
wrdApp.Selection.ParagraphFormat.SpaceAfter = 0
wrdApp.Selection.ParagraphFormat.LineSpacing = 0
wrdApp.Selection.TypeText Text:="Report for"
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeText Text:=Client
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeParagraph
'--------------------------------------------------------------------------- Funds on first page
wrdApp.Selection.Style = "DocSubtitle"
For k = 1 To j
wrdApp.Selection.Font.Color = RGB(255, 0, 0)
wrdApp.Selection.Font.Name = "Arial"
wrdApp.Selection.Font.Size = 11
wrdApp.Selection.Font.Bold = True
t = vbTab
For y = 1 To j
If Len(ContractTYPE(y)) > 3 Then
t = vbTab & vbTab
End If
Next y
If Len(ContractTYPE(k)) > 3 Then
wrdApp.Selection.TypeText Text:=ContractTYPE(k) & ":" & vbTab & FundName(k) & " - " & Supplier(k)
wrdApp.Selection.TypeParagraph
Else
wrdApp.Selection.TypeText Text:=ContractTYPE(k) & ":" & t & FundName(k) & " - " & Supplier(k)
wrdApp.Selection.TypeParagraph
End If
Next k
wrdApp.Selection.TypeParagraph
'--------------------------------------------------------------------------- Date
wrdApp.Selection.TypeText Text:="Date:" & t & Format(Date, "dd MMMM yyyy")
wrdApp.Selection.TypeParagraph
'--------------------------------------------------------------------------- Funds and graphs on page
For k = 1 To j
If FileFolderExists(ThisWorkbook.Path & "\Graphs " & Format(Date, "yyyy-MM-dd") _
& Application.PathSeparator & FundID(k) & " - " & FundName(k) & " - " & Client & ".doc") Then
wrdApp.Selection.InsertFile ThisWorkbook.Path & "\Graphs " & Format(Date, "yyyy-MM-dd") _
& Application.PathSeparator & FundID(k) & " - " & FundName(k) & " - " & Client & ".doc", "", False, False, False
Else
wrdApp.Selection.Style = "Heading 1"
wrdApp.Selection.TypeText Text:=ContractTYPE(k) & ": " & FundName(k)
wrdApp.Selection.TypeParagraph
wrdApp.Selection.InsertFile ThisWorkbook.Path & "\Graphs " & Format(Date, "yyyy-MM-dd") _
& Application.PathSeparator & "___" & FundID(k) & " - " & FundName(k) & ".doc", "", False, False, False
End If
Next k
'--------------------------------------------------------------------------- Coments
wrdApp.Selection.InsertFile ThisWorkbook.Path & "\Coments.doc", "", False, False, False
'--------------------------------------------------------------------------- Contacts
wrdApp.Selection.Style = "Heading 1"
wrdApp.Selection.TypeText Text:="Contacts"
wrdApp.Selection.TypeParagraph
wrdApp.Selection.Style = "No Spacing"
wrdApp.Selection.Font.Name = "Arial"
wrdApp.Selection.Font.Size = 11
wrdApp.Selection.Font.Bold = False
wrdApp.Selection.ParagraphFormat.SpaceAfter = 0
wrdApp.Selection.ParagraphFormat.LineSpacingRule = "Single"
wrdApp.Selection.ParagraphFormat.LineSpacing = 0
wrdApp.Selection.TypeText Text:="For further information please contact your Relationship Manager:"
'--------------------------------------------------------------------------- Contacts RM
k = 1
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeText Text:=RM(k)
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeText Text:=JobTitle(k)
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeParagraph
If Len(Phone(k)) > 1 Then
wrdApp.Selection.TypeText Text:="T " & Phone(k)
wrdApp.Selection.TypeParagraph
End If
If Len(Mobile(k)) > 1 Then
wrdApp.Selection.TypeText Text:="M " & Mobile(k)
wrdApp.Selection.TypeParagraph
End If
wrdApp.Selection.TypeText Text:="E "
Dim RngEmail As Word.Range
Set RngEmail = .Content
RngEmail.Collapse wdCollapseEnd
.Hyperlinks.Add Anchor:=RngEmail, Address:="Mailto:%20" & _
Email(k), SubAddress:="", ScreenTip:="", TextToDisplay _
:=Email(k), Target:="": RngEmail.Collapse wdCollapseEnd
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeParagraph
If Len(TA(k)) > 1 Then
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeText Text:="Trading Assistant contact details:"
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeText Text:=TA(k)
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeText Text:="Trading Assistant"
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeParagraph
If Len(TA_Phone(k)) > 1 Then
wrdApp.Selection.TypeText Text:="T " & TA_Phone(k)
wrdApp.Selection.TypeParagraph
End If
wrdApp.Selection.TypeText Text:="E "
Set RngEmail = .Content
RngEmail.Collapse wdCollapseEnd
.Hyperlinks.Add Anchor:=RngEmail, Address:="Mailto:%20" & _
TA_Email(k), SubAddress:="", ScreenTip:="", TextToDisplay:=TA_Email(k), Target:=""
RngEmail.Collapse wdCollapseEnd
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeParagraph
End If
wrdApp.Selection.TypeText Text:="Address"
'---------------------------------------------------------------------------Disclaimer
wrdApp.ActiveWindow.ActivePane.View.Type = 3
wrdApp.ActiveWindow.ActivePane.View.SeekView = 10
wrdApp.Selection.InsertParagraphAfter
wrdApp.Selection.InsertFile ThisWorkbook.Path & "\Disclaimer.doc", "", False, False, False
wrdApp.Selection.InsertAfter "REPORT - " & Client
'--------------------------------------------------------------------------- Display only text (not blank space)
'With wrdApp.ActiveWindow.ActivePane.View
' .SeekView = wdSeekMainDocument
' .DisplayPageBoundaries = Not .DisplayPageBoundaries
'End With
'---------------------------------------------------------------------------
.SaveAs (MyName & "\Reports as at " & Format(Date, "yyyy-mm-dd") & Application.PathSeparator & Surname(k) & Application.PathSeparator & Client & _
" - Report as at " & Format(Date, "yyyy-MM-dd") & " " & Initials(k) & ".doc")
.Content.Clear
End With
wrdApp.Quit ' close the Word application
Set wrdDoc = Nothing
Set wrdApp = Nothing
.AutoFilterMode = False
Next CUniqueClient
Range(.Cells(Rows.Count, "A").End(xlUp), .Cells(Rows.Count, "A").End(xlUp).End(xlUp)).Cells.Clear
End With
Application.StatusBar = False
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "Elapsed Time " & Format(Now() - Speed, "hh:mm:ss")
End Sub
Public Function FileFolderExists(strFullPath As String) As Boolean
On Error GoTo EarlyExit
If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
EarlyExit:
On Error GoTo 0
End Function
Thank you
Bogdan
Hello
I need to create about 100 word reports from an excel "database"
Please help me with speeding up the following code:
'------------------------------------------
' Working 2012-05-15
'------------------------------------------
Option Explicit
Sub WordGenerate()
Dim CL As Range, rdata As Range, filt As Range
Dim UniqueClient As Range, CUniqueClient As Range, Dest As Range
Dim Client As String, RM() As String, TA() As String, TA_Email() As String, TA_Phone() As String
Dim ContractTYPE() As String, Supplier() As String, FundID() As String, FundName() As String, Email() As String
Dim Phone() As String, Mobile() As String, JobTitle() As String, Initials() As String, Surname() As String
Dim i As Integer, j As Integer, k As Integer, y As Integer, Speed As Date
Dim wrdApp As Object, tmpDoc As Object, wrdDoc As Object, WRng As Object, wrdRange As Object
Dim WDoc As String, myDoc As String, x As String, Path As String, t As String, MyName As String
Dim strBar As String
Dim lngLoop As Integer
Application.ScreenUpdating = False
Application.EnableEvents = False
Speed = Now()
With Worksheets("DB")
Set CL = Range(.Range("A1"), .Range("A1").End(xlDown))
Set UniqueClient = .Range("A1").End(xlDown).Offset(5, 0)
CL.AdvancedFilter xlFilterCopy, , UniqueClient, True
Set UniqueClient = Range(UniqueClient.Offset(1, 0), UniqueClient.End(xlDown))
Set rdata = .Range("A1").CurrentRegion
rdata.Sort key1:=.Range("A1"), header:=xlYes
MyName = ThisWorkbook.Path
myDoc = "Fund Purchasing Report - Template.doc"
WDoc = MyName & Application.PathSeparator & myDoc
On Error Resume Next
MkDir MyName & "\Reports as at " & Format(Date, "yyyy-mm-dd")
On Error GoTo 0
i = 1
For Each CUniqueClient In UniqueClient
x = CUniqueClient.Value
lngLoop = UniqueClient.Rows.Count
rdata.AutoFilter field:=1, Criteria1:=x
Set filt = rdata.Offset(1, 0).Resize(rdata.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
Client = filt.Areas(1).Cells(1, "A").Value
j = filt.Areas(1).Rows.Count
i = i + 1
strBar = String(Round(i / lngLoop * 15, 0), ChrW(&H25A0)) & String(15 - Round(15 * i / lngLoop, 0), ChrW(&H25A1))
Application.StatusBar = strBar & Format((i - 1) / lngLoop, " 0%") & " Save report for: " & x
ReDim RM(1 To j)
ReDim TA(1 To j)
ReDim ContractTYPE(1 To j)
ReDim Supplier(1 To j)
ReDim FundID(1 To j)
ReDim FundName(1 To j)
ReDim Email(1 To j)
ReDim Phone(1 To j)
ReDim Mobile(1 To j)
ReDim JobTitle(1 To j)
ReDim Initials(1 To j)
ReDim Surname(1 To j)
ReDim TA_Email(1 To j)
ReDim TA_Phone(1 To j)
For k = 1 To j
Client = filt.Areas(1).Cells(k, "A").Value
RM(k) = filt.Areas(1).Cells(k, "B").Value
TA(k) = filt.Areas(1).Cells(k, "C").Value
ContractTYPE(k) = filt.Areas(1).Cells(k, "E").Value
Supplier(k) = filt.Areas(1).Cells(k, "F").Value
FundID(k) = filt.Areas(1).Cells(k, "H").Value
FundName(k) = filt.Areas(1).Cells(k, "I").Value
Email(k) = filt.Areas(1).Cells(k, "J").Value
Phone(k) = filt.Areas(1).Cells(k, "K").Value
Mobile(k) = filt.Areas(1).Cells(k, "L").Value
JobTitle(k) = filt.Areas(1).Cells(k, "M").Value
Initials(k) = filt.Areas(1).Cells(k, "N").Value
Surname(k) = filt.Areas(1).Cells(k, "O").Value
TA_Email(k) = filt.Areas(1).Cells(k, "P").Value
TA_Phone(k) = filt.Areas(1).Cells(k, "Q").Value
Next k
'-----------------------------------------------------------------------------
On Error Resume Next
For k = 1 To j
MkDir MyName & "\Reports as at " & Format(Date, "yyyy-mm-dd") & Application.PathSeparator & Surname(k)
Next k
On Error GoTo 0
'-----------------------------------------------------------------------------
On Error Resume Next
Set wrdApp = GetObject(, "Word.Application")
If wrdApp Is Nothing Then
' no current word application
Set wrdApp = CreateObject("Word.application")
Set wrdDoc = wrdApp.Documents.Open(WDoc)
wrdApp.Visible = False
Else
' word app running
For Each tmpDoc In wrdApp.Documents
If StrComp(tmpDoc.FullName, WDoc, vbTextCompare) = 0 Then
' this is your doc
Set wrdDoc = tmpDoc
Exit For
End If
Next
If wrdDoc Is Nothing Then
' not open
Set wrdDoc = wrdApp.Documents.Open(WDoc)
End If
End If
'-----------------------------------------------------------------------------
Set wrdRange = wrdDoc
With wrdDoc
wrdApp.Selection.Style = "DocTitle"
wrdApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
wrdApp.Selection.Font.Color = RGB(166, 166, 166) 'Title
wrdApp.Selection.Font.Name = "Georgia"
wrdApp.Selection.Font.Size = 26
wrdApp.Selection.ParagraphFormat.SpaceAfter = 18
wrdApp.Selection.ParagraphFormat.LineSpacingRule = "At least"
wrdApp.Selection.ParagraphFormat.LineSpacing = 13
wrdApp.Selection.TypeText Text:="Trader SRL"
wrdApp.Selection.TypeParagraph
wrdApp.Selection.Font.Color = RGB(51, 51, 153) 'Title
wrdApp.Selection.Font.Name = "Georgia"
wrdApp.Selection.Font.Size = 23
wrdApp.Selection.ParagraphFormat.SpaceAfter = 0
wrdApp.Selection.ParagraphFormat.LineSpacing = 0
wrdApp.Selection.TypeText Text:="Report for"
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeText Text:=Client
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeParagraph
'--------------------------------------------------------------------------- Funds on first page
wrdApp.Selection.Style = "DocSubtitle"
For k = 1 To j
wrdApp.Selection.Font.Color = RGB(255, 0, 0)
wrdApp.Selection.Font.Name = "Arial"
wrdApp.Selection.Font.Size = 11
wrdApp.Selection.Font.Bold = True
t = vbTab
For y = 1 To j
If Len(ContractTYPE(y)) > 3 Then
t = vbTab & vbTab
End If
Next y
If Len(ContractTYPE(k)) > 3 Then
wrdApp.Selection.TypeText Text:=ContractTYPE(k) & ":" & vbTab & FundName(k) & " - " & Supplier(k)
wrdApp.Selection.TypeParagraph
Else
wrdApp.Selection.TypeText Text:=ContractTYPE(k) & ":" & t & FundName(k) & " - " & Supplier(k)
wrdApp.Selection.TypeParagraph
End If
Next k
wrdApp.Selection.TypeParagraph
'--------------------------------------------------------------------------- Date
wrdApp.Selection.TypeText Text:="Date:" & t & Format(Date, "dd MMMM yyyy")
wrdApp.Selection.TypeParagraph
'--------------------------------------------------------------------------- Funds and graphs on page
For k = 1 To j
If FileFolderExists(ThisWorkbook.Path & "\Graphs " & Format(Date, "yyyy-MM-dd") _
& Application.PathSeparator & FundID(k) & " - " & FundName(k) & " - " & Client & ".doc") Then
wrdApp.Selection.InsertFile ThisWorkbook.Path & "\Graphs " & Format(Date, "yyyy-MM-dd") _
& Application.PathSeparator & FundID(k) & " - " & FundName(k) & " - " & Client & ".doc", "", False, False, False
Else
wrdApp.Selection.Style = "Heading 1"
wrdApp.Selection.TypeText Text:=ContractTYPE(k) & ": " & FundName(k)
wrdApp.Selection.TypeParagraph
wrdApp.Selection.InsertFile ThisWorkbook.Path & "\Graphs " & Format(Date, "yyyy-MM-dd") _
& Application.PathSeparator & "___" & FundID(k) & " - " & FundName(k) & ".doc", "", False, False, False
End If
Next k
'--------------------------------------------------------------------------- Coments
wrdApp.Selection.InsertFile ThisWorkbook.Path & "\Coments.doc", "", False, False, False
'--------------------------------------------------------------------------- Contacts
wrdApp.Selection.Style = "Heading 1"
wrdApp.Selection.TypeText Text:="Contacts"
wrdApp.Selection.TypeParagraph
wrdApp.Selection.Style = "No Spacing"
wrdApp.Selection.Font.Name = "Arial"
wrdApp.Selection.Font.Size = 11
wrdApp.Selection.Font.Bold = False
wrdApp.Selection.ParagraphFormat.SpaceAfter = 0
wrdApp.Selection.ParagraphFormat.LineSpacingRule = "Single"
wrdApp.Selection.ParagraphFormat.LineSpacing = 0
wrdApp.Selection.TypeText Text:="For further information please contact your Relationship Manager:"
'--------------------------------------------------------------------------- Contacts RM
k = 1
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeText Text:=RM(k)
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeText Text:=JobTitle(k)
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeParagraph
If Len(Phone(k)) > 1 Then
wrdApp.Selection.TypeText Text:="T " & Phone(k)
wrdApp.Selection.TypeParagraph
End If
If Len(Mobile(k)) > 1 Then
wrdApp.Selection.TypeText Text:="M " & Mobile(k)
wrdApp.Selection.TypeParagraph
End If
wrdApp.Selection.TypeText Text:="E "
Dim RngEmail As Word.Range
Set RngEmail = .Content
RngEmail.Collapse wdCollapseEnd
.Hyperlinks.Add Anchor:=RngEmail, Address:="Mailto:%20" & _
Email(k), SubAddress:="", ScreenTip:="", TextToDisplay _
:=Email(k), Target:="": RngEmail.Collapse wdCollapseEnd
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeParagraph
If Len(TA(k)) > 1 Then
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeText Text:="Trading Assistant contact details:"
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeText Text:=TA(k)
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeText Text:="Trading Assistant"
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeParagraph
If Len(TA_Phone(k)) > 1 Then
wrdApp.Selection.TypeText Text:="T " & TA_Phone(k)
wrdApp.Selection.TypeParagraph
End If
wrdApp.Selection.TypeText Text:="E "
Set RngEmail = .Content
RngEmail.Collapse wdCollapseEnd
.Hyperlinks.Add Anchor:=RngEmail, Address:="Mailto:%20" & _
TA_Email(k), SubAddress:="", ScreenTip:="", TextToDisplay:=TA_Email(k), Target:=""
RngEmail.Collapse wdCollapseEnd
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeParagraph
End If
wrdApp.Selection.TypeText Text:="Address"
'---------------------------------------------------------------------------Disclaimer
wrdApp.ActiveWindow.ActivePane.View.Type = 3
wrdApp.ActiveWindow.ActivePane.View.SeekView = 10
wrdApp.Selection.InsertParagraphAfter
wrdApp.Selection.InsertFile ThisWorkbook.Path & "\Disclaimer.doc", "", False, False, False
wrdApp.Selection.InsertAfter "REPORT - " & Client
'--------------------------------------------------------------------------- Display only text (not blank space)
'With wrdApp.ActiveWindow.ActivePane.View
' .SeekView = wdSeekMainDocument
' .DisplayPageBoundaries = Not .DisplayPageBoundaries
'End With
'---------------------------------------------------------------------------
.SaveAs (MyName & "\Reports as at " & Format(Date, "yyyy-mm-dd") & Application.PathSeparator & Surname(k) & Application.PathSeparator & Client & _
" - Report as at " & Format(Date, "yyyy-MM-dd") & " " & Initials(k) & ".doc")
.Content.Clear
End With
wrdApp.Quit ' close the Word application
Set wrdDoc = Nothing
Set wrdApp = Nothing
.AutoFilterMode = False
Next CUniqueClient
Range(.Cells(Rows.Count, "A").End(xlUp), .Cells(Rows.Count, "A").End(xlUp).End(xlUp)).Cells.Clear
End With
Application.StatusBar = False
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "Elapsed Time " & Format(Now() - Speed, "hh:mm:ss")
End Sub
Public Function FileFolderExists(strFullPath As String) As Boolean
On Error GoTo EarlyExit
If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
EarlyExit:
On Error GoTo 0
End Function
Thank you
Bogdan