We help IT Professionals succeed at work.
Get Started

VBA Optimization

hragape
hragape asked
on
884 Views
Last Modified: 2012-03-24
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
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

Open in new window

Comment
Watch Question
CERTIFIED EXPERT
Commented:
This problem has been solved!
Unlock 1 Answer and 4 Comments.
See Answer
Why Experts Exchange?

Experts Exchange always has the answer, or at the least points me in the correct direction! It is like having another employee that is extremely experienced.

Jim Murphy
Programmer at Smart IT Solutions

When asked, what has been your best career decision?

Deciding to stick with EE.

Mohamed Asif
Technical Department Head

Being involved with EE helped me to grow personally and professionally.

Carl Webster
CTP, Sr Infrastructure Consultant
Ask ANY Question

Connect with Certified Experts to gain insight and support on specific technology challenges including:

  • Troubleshooting
  • Research
  • Professional Opinions
Did You Know?

We've partnered with two important charities to provide clean water and computer science education to those who need it most. READ MORE