hragape
asked on
VBA Optimization
I am new at VBA programming. Can somebody review my attached code? The solution works but the code seems to be very inefficient.
Thank You
Thank You
Sub test_Create_Templates()
'Declare Variables
Dim appWord As Word.Application, docWord As Word.Document, docWord_Template As Word.Document
Dim lngRow As Long, lngRowCount As Long
Dim strFilePath As String
Dim strFileName As String
Dim strTemplatePath As String
Dim strTemplateExcel As String
Dim strTemplateName As String
Dim strReplacement As String
' Set Variable Values
strFilePath = "C:\automation\MA_SDU\"
' Later - Remove Hard Coded Instance below
strTemplatePath = "C:\automation\bd\boilerplate\"
strTemplateName = "C:\automation\bd\tools\rfp Template_MA.docx"
lngRowCount = Cells(Rows.Count, "D").End(xlUp).Row
'Open Word
Set appWord = New Word.Application
' For each Excel row get the file name and open
' Hard Code lngRow value to start at the first row fo the table
For lngRow = 3 To lngRowCount
If Cells(lngRow, "B").Value <> "" Then ' Check for Section Title Value
'
' Create a new Document if header style = Heading 1
' Else add information to existing document
If Cells(lngRow, "D").Value = "Heading 1" Then
'Save As Tab Name from Excel Columns
strFileName = strFilePath & Cells(lngRow, "K").Value & ".doc"
' Stop and go to next row if file allready exists
If FileExists(strFileName) = False Then
' Open Word Proposal Template
' TBD - Set document path to a relative path
Set docWord_Template = appWord.Documents.Open("C:\automation\bd\tools\rfp Template_MA.docx", ReadOnly)
docWord_Template.SaveAs (strFileName)
End If ' Checking if File allready Exists
End If ' Create new document if Heading 1
' Start - Insert Section Title
' Go To End of Document
Set Rng = docWord_Template.Range
Rng.EndOf wdStory, wdMove
' Insert Section Title from Excel
Rng.Text = Cells(lngRow, "A").Value & " " & Cells(lngRow, "B").Value & vbNewLine & vbNewLine & vbNewLine
'Apply Heading Style Using Replace
With Rng.Find
.Text = Cells(lngRow, "A").Value & " " & Cells(lngRow, "B").Value
.Replacement.Text = Cells(lngRow, "A").Value & " " & Cells(lngRow, "B").Value
.Replacement.Style = Cells(lngRow, "D")
.Execute Replace:=wdReplaceAll
End With ' End Replace Heading
' Insert RFP Requirements from Excel
' Go To End of Document
Set Rng = docWord_Template.Range
Rng.EndOf wdStory, wdMove
If Cells(lngRow, "C").Value <> "" Then ' Check for Requirement Text
Rng.Text = vbNewLine & Cells(lngRow, "C").Value
Rng.Style = "RFP Text"
End If ' Check for Requirement Text
' Add two lines and set to Normal to make typing easier
Set Rng = docWord_Template.Range
Rng.EndOf wdStory, wdMove
Rng.Text = vbNewLine & vbNewLine
Rng.Style = "Normal"
'
' Start Inserting Boiler Plate Files
' Check 5 columns for File Name
'
'Start - Check for Boilerplate Value - 1st Column
If Cells(lngRow, "F").Value <> "" Then
strTemplateName = strTemplatePath & Cells(lngRow, "F")
Set Rng = docWord_Template.Range
Rng.EndOf wdStory, wdMove
Rng.InsertFile Filename:=strTemplateName, Range:="", ConfirmConversions:=False, Link:=False, Attachment:=False
Rng.Text = vbCrLf
Rng.Style = "Normal"
End If ' End Check for Boilerplate Value - 1st Column
'Start - Check for Boilerplate Value - 2nd Column
If Cells(lngRow, "G").Value <> "" Then
strTemplateName = strTemplatePath & Cells(lngRow, "G")
Set Rng = docWord_Template.Range
Rng.EndOf wdStory, wdMove
Rng.InsertFile Filename:=strTemplateName, Range:="", ConfirmConversions:=False, Link:=False, Attachment:=False
Rng.Text = vbCrLf
Rng.Style = "Normal"
End If ' End Check for Boilerplate Value - 2nd Column
'Start - Check for Boilerplate Value - 3rd Column
If Cells(lngRow, "H").Value <> "" Then
strTemplateName = strTemplatePath & Cells(lngRow, "H")
Set Rng = docWord_Template.Range
Rng.EndOf wdStory, wdMove
Rng.InsertFile Filename:=strTemplateName, Range:="", ConfirmConversions:=False, Link:=False, Attachment:=False
Rng.Text = vbCrLf
Rng.Style = "Normal"
End If ' End Check for Boilerplate Value - 3rd Column
' Start - Check for Boilerplate Value - 4th Column
If Cells(lngRow, "I").Value <> "" Then
strTemplateName = strTemplatePath & Cells(lngRow, "I")
Set Rng = docWord_Template.Range
Rng.EndOf wdStory, wdMove
Rng.InsertFile Filename:=strTemplateName, Range:="", ConfirmConversions:=False, Link:=False, Attachment:=False
Rng.Text = vbCrLf
Rng.Style = "Normal"
End If ' End Check for Boilerplate Value - 4th Column
' Start - Check for Boilerplate Value - 5th Column
If Cells(lngRow, "J").Value <> "" Then
strTemplateName = strTemplatePath & Cells(lngRow, "J")
Set Rng = docWord_Template.Range
Rng.EndOf wdStory, wdMove
Rng.InsertFile Filename:=strTemplateName, Range:="", ConfirmConversions:=False, Link:=False, Attachment:=False
Rng.Text = vbCrLf
Rng.Style = "Normal"
End If ' End Check for Boilerplate Value - 5th Column
'
' End Insert Boiler Plate File
' Check 5 columns for File Name
'
docWord_Template.SaveAs (strFileName)
Else
' Close Document
docWord_Template.Close (wdSaveChanges = -1)
strFileName = " "
End If ' Check For Section Title Value
Next lngRow
appWord.Quit
Set appWord = Nothing
End Sub
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Hi Jeggburt,
Thank you for the quick response. That is a very helpful change.
Thank you for the quick response. That is a very helpful change.
ASKER
Jeggburt,
Your suggestion lead to a noticeable increase in execution time when I processed 99 rows. I have attached the new code.
Do you have any suggestions on how to improve the way that I am
1. assigning formatting
2. Inserting a line so that the writers will be able to start typing in "normal" style instead of the style that I have assigned.
Thanks Again
Your suggestion lead to a noticeable increase in execution time when I processed 99 rows. I have attached the new code.
Do you have any suggestions on how to improve the way that I am
1. assigning formatting
2. Inserting a line so that the writers will be able to start typing in "normal" style instead of the style that I have assigned.
Thanks Again
Sub test_Create_Templates()
'Declare Variables
Dim appWord As Word.Application, docWord As Word.Document, docWord_Template As Word.Document
Dim lngRow As Long, lngRowCount As Long
Dim strFilePath As String
Dim strFileName As String
Dim strTemplatePath As String
Dim strTemplateExcel As String
Dim strTemplateName As String
Dim strReplacement As String
' Set Variable Values
strFilePath = "C:\automation\MA_SDU\"
' Later - Remove Hard Coded Instance below
strTemplatePath = "C:\automation\bd\boilerplate\"
strTemplateName = "C:\automation\bd\tools\rfp Template_MA.docx"
lngRowCount = Cells(Rows.Count, "D").End(xlUp).Row
'Open Word
Set appWord = New Word.Application
' For each Excel row get the file name and open
' Hard Code lngRow value to start at the first row fo the table
For lngRow = 3 To lngRowCount
If Cells(lngRow, "B").Value <> "" Then ' Check for Section Title Value
'
' Create a new Document if header style = Heading 1
' Else add information to existing document
If Cells(lngRow, "D").Value = "Heading 1" Then
'Save As Tab Name from Excel Columns
strFileName = strFilePath & Cells(lngRow, "K").Value & ".doc"
' Stop and go to next row if file allready exists
If FileExists(strFileName) = False Then
' Open Word Proposal Template
' TBD - Set document path to a relative path
Set docWord_Template = appWord.Documents.Open("C:\automation\bd\tools\rfp Template_MA.docx", ReadOnly)
docWord_Template.SaveAs (strFileName)
End If ' Checking if File allready Exists
End If ' Create new document if Heading 1
' Start - Insert Section Title
' Go To End of Document
Set Rng = docWord_Template.Range
Rng.EndOf wdStory, wdMove
' Insert Section Title from Excel
Rng.Text = Cells(lngRow, "A").Value & " " & Cells(lngRow, "B").Value & vbNewLine & vbNewLine & vbNewLine
'Apply Heading Style Using Replace
With Rng.Find
.Text = Cells(lngRow, "A").Value & " " & Cells(lngRow, "B").Value
.Replacement.Text = Cells(lngRow, "A").Value & " " & Cells(lngRow, "B").Value
.Replacement.Style = Cells(lngRow, "D")
.Execute Replace:=wdReplaceAll
End With ' End Replace Heading
' Insert RFP Requirements from Excel
' Go To End of Document
Set Rng = docWord_Template.Range
Rng.EndOf wdStory, wdMove
If Cells(lngRow, "C").Value <> "" Then ' Check for Requirement Text
Rng.Text = vbNewLine & Cells(lngRow, "C").Value
Rng.Style = "RFP Text"
End If ' Check for Requirement Text
' Add two lines and set to Normal to make typing easier
Set Rng = docWord_Template.Range
Rng.EndOf wdStory, wdMove
Rng.Text = vbNewLine & vbNewLine
Rng.Style = "Normal"
'
' Start Inserting Boiler Plate Files
' Check 5 columns for File Name
'
For j = 6 To 10
If Cells(lngRow, j).Value <> "" Then
strTemplateName = strTemplatePath & Cells(lngRow, j)
Set Rng = docWord_Template.Range
Rng.EndOf wdStory, wdMove
Rng.InsertFile Filename:=strTemplateName, Range:="", ConfirmConversions:=False, Link:=False, Attachment:=False
Rng.Text = vbCrLf
Rng.Style = "Normal"
End If
Next j
docWord_Template.SaveAs (strFileName)
'
' End Inserting Boiler Plate Files
' Check 5 columns for File Name
'
Else
' Close Document
docWord_Template.Close (wdSaveChanges = -1)
strFileName = " "
End If ' Check For Section Title Value
Next lngRow
appWord.Quit
Set appWord = Nothing
End Sub
You could use a For Next Loop instead
Open in new window