Make VBA code more efficient

J

johnodocs

New Member
Joined
Oct 31, 2015
Messages
23
Hi all,

I managed to write/copy and paste some VBA code a few years ago to create a multiple word documents based on template word document files and a long list of students, their teacher and their group name is excel. We have 1,200 records.

It works and does what is needs to do but it takes about 3 hours to make all the reports. I wondered if I had done anything that is just not good VBA practice. Is there a way to quicken it up?

I appreicate the time anyone spends looking into this.

John

*********

Sub Report_Generator()

Dim wApp As Word.Application
Dim wDoc As Word.Document
Dim TeacherName As String
Dim GroupName As String
Dim StudentName As String
Dim Template As String
Dim FileYear As String
Dim Answer As Integer

Dim StartTime As Double
Dim MinutesElapsed As String

Answer = MsgBox("Are you sure you are ready to do this? Have you done all the necessary checks? Remember this will take a LONG time.", vbYesNo + vbQuestion, "Empty Sheet")

If Answer = vbNo Then

Exit Sub

Else

'makes partent reports

End If
FileYear = InputBox("What academic year is it? e.g. 17-18")

StartTime = Timer


Sheets("Data").Select
FinalRow = Range("A9999").End(xlUp).Row

For I = 2 To FinalRow
Sheets("Data").Select

Range("A" & I).Copy Destination:=Sheets("Template").Range("A1")
Range("B" & I & ":E" & I).Copy
Sheets("Template").Select
Range("A2").PasteSpecial Transpose:=True

Range("A1:A3").Copy


StudentName = Sheets("Template").Range("A1").Text
GroupName = Sheets("Template").Range("A2").Text
TeacherName = Sheets("Template").Range("A3").Text
Template = Sheets("Template").Range("A4").Text

If Dir((ActiveWorkbook.Path) & "/" & TeacherName, vbDirectory) = "" Then

MkDir (ActiveWorkbook.Path) & "/" & TeacherName

Else

End If

If Dir((ActiveWorkbook.Path) & "/" & TeacherName & "/" & GroupName, vbDirectory) = "" Then

MkDir (ActiveWorkbook.Path) & "/" & TeacherName & "/" & GroupName

Else

End If
'Movers and flyers

If Template = "EVALUATION REPORT Movers & Flyers" Then

Set wApp = CreateObject("Word.Application")
'wApp.Visible = True
Set wDoc = wApp.Documents.Open(ActiveWorkbook.Path & "" & "templates" & "/" & "EVALUATION REPORT Movers & Flyers.docx")

With wDoc
.Application.Selection.Find.Text = "<<NAME>>"
.Application.Selection.Find.Execute
.Application.Selection = StudentName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<GROUP>>"
.Application.Selection.Find.Execute
.Application.Selection = GroupName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<TEACHER>>"
.Application.Selection.Find.Execute
.Application.Selection = TeacherName
.Application.Selection.EndOf


.SaveAs (ActiveWorkbook.Path & "" & TeacherName & "") & GroupName & "" & StudentName & "" & " " & FileYear

End With


End If

'1 primary

If Template = "EVALUATION REPORT 1st Primary" Then

Set wApp = CreateObject("Word.Application")
'wApp.Visible = True
Set wDoc = wApp.Documents.Open(ActiveWorkbook.Path & "" & "templates" & "/" & "EVALUATION REPORT 1st Primary.docx")

With wDoc
.Application.Selection.Find.Text = "<<NAME>>"
.Application.Selection.Find.Execute
.Application.Selection = StudentName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<GROUP>>"
.Application.Selection.Find.Execute
.Application.Selection = GroupName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<TEACHER>>"
.Application.Selection.Find.Execute
.Application.Selection = TeacherName
.Application.Selection.EndOf


.SaveAs (ActiveWorkbook.Path & "" & TeacherName & "") & GroupName & "" & StudentName & " " & FileYear

End With

End If

'infants

If Template = "EVALUATION REPORT Infants" Then

Set wApp = CreateObject("Word.Application")
'wApp.Visible = True
Set wDoc = wApp.Documents.Open(ActiveWorkbook.Path & "" & "templates" & "/" & "EVALUATION REPORT Infants.docx")

With wDoc
.Application.Selection.Find.Text = "<<NAME>>"
.Application.Selection.Find.Execute
.Application.Selection = StudentName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<GROUP>>"
.Application.Selection.Find.Execute
.Application.Selection = GroupName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<TEACHER>>"
.Application.Selection.Find.Execute
.Application.Selection = TeacherName
.Application.Selection.EndOf


.SaveAs (ActiveWorkbook.Path & "" & TeacherName & "") & GroupName & "" & StudentName & " " & FileYear

End With

End If

'B1 blast

If Template = "EVALUATION REPORT PET1 BLAST" Then

Set wApp = CreateObject("Word.Application")
'wApp.Visible = True
Set wDoc = wApp.Documents.Open(ActiveWorkbook.Path & "" & "templates" & "/" & "EVALUATION REPORT PET1 BLAST.docx")

With wDoc
.Application.Selection.Find.Text = "<<NAME>>"
.Application.Selection.Find.Execute
.Application.Selection = StudentName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<GROUP>>"
.Application.Selection.Find.Execute
.Application.Selection = GroupName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<TEACHER>>"
.Application.Selection.Find.Execute
.Application.Selection = TeacherName
.Application.Selection.EndOf


.SaveAs (ActiveWorkbook.Path & "" & TeacherName & "") & GroupName & "" & StudentName & " " & FileYear

End With

End If

'PET2 and 3

If Template = "EVALUATION REPORT PET23" Then

Set wApp = CreateObject("Word.Application")
'wApp.Visible = True
Set wDoc = wApp.Documents.Open(ActiveWorkbook.Path & "" & "templates" & "/" & "EVALUATION REPORT PET23.docx")

With wDoc
.Application.Selection.Find.Text = "<<NAME>>"
.Application.Selection.Find.Execute
.Application.Selection = StudentName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<GROUP>>"
.Application.Selection.Find.Execute
.Application.Selection = GroupName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<TEACHER>>"
.Application.Selection.Find.Execute
.Application.Selection = TeacherName
.Application.Selection.EndOf


.SaveAs (ActiveWorkbook.Path & "" & TeacherName & "") & GroupName & "" & StudentName & " " & FileYear

End With

End If

'´FCE 1

If Template = "EVALUATION REPORT FCE1" Then

Set wApp = CreateObject("Word.Application")
'wApp.Visible = True
Set wDoc = wApp.Documents.Open(ActiveWorkbook.Path & "" & "templates" & "/" & "EVALUATION REPORT FCE1.docx")

With wDoc
.Application.Selection.Find.Text = "<<NAME>>"
.Application.Selection.Find.Execute
.Application.Selection = StudentName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<GROUP>>"
.Application.Selection.Find.Execute
.Application.Selection = GroupName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<TEACHER>>"
.Application.Selection.Find.Execute
.Application.Selection = TeacherName
.Application.Selection.EndOf


.SaveAs (ActiveWorkbook.Path & "" & TeacherName & "") & GroupName & "" & StudentName & " " & FileYear

End With

End If

'FCE 2

If Template = "EVALUATION REPORT FCE2" Then

Set wApp = CreateObject("Word.Application")
'wApp.Visible = True
Set wDoc = wApp.Documents.Open(ActiveWorkbook.Path & "" & "templates" & "/" & "EVALUATION REPORT FCE2.docx")

With wDoc
.Application.Selection.Find.Text = "<<NAME>>"
.Application.Selection.Find.Execute
.Application.Selection = StudentName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<GROUP>>"
.Application.Selection.Find.Execute
.Application.Selection = GroupName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<TEACHER>>"
.Application.Selection.Find.Execute
.Application.Selection = TeacherName
.Application.Selection.EndOf


.SaveAs (ActiveWorkbook.Path & "" & TeacherName & "") & GroupName & "" & StudentName & " " & FileYear

End With

End If

'FCE3

If Template = "EVALUATION REPORT FCE34" Then

Set wApp = CreateObject("Word.Application")
'wApp.Visible = True
Set wDoc = wApp.Documents.Open(ActiveWorkbook.Path & "" & "templates" & "/" & "EVALUATION REPORT FCE34.docx")

With wDoc
.Application.Selection.Find.Text = "<<NAME>>"
.Application.Selection.Find.Execute
.Application.Selection = StudentName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<GROUP>>"
.Application.Selection.Find.Execute
.Application.Selection = GroupName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<TEACHER>>"
.Application.Selection.Find.Execute
.Application.Selection = TeacherName
.Application.Selection.EndOf


.SaveAs (ActiveWorkbook.Path & "" & TeacherName & "") & GroupName & "" & StudentName & " " & FileYear

End With

End If

'CAE1

If Template = "EVALUATION REPORT CAE1" Then

Set wApp = CreateObject("Word.Application")
'wApp.Visible = True
Set wDoc = wApp.Documents.Open(ActiveWorkbook.Path & "" & "templates" & "/" & "EVALUATION REPORT CAE1.docx")

With wDoc
.Application.Selection.Find.Text = "<<NAME>>"
.Application.Selection.Find.Execute
.Application.Selection = StudentName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<GROUP>>"
.Application.Selection.Find.Execute
.Application.Selection = GroupName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<TEACHER>>"
.Application.Selection.Find.Execute
.Application.Selection = TeacherName
.Application.Selection.EndOf


.SaveAs (ActiveWorkbook.Path & "" & TeacherName & "") & GroupName & "" & StudentName & " " & FileYear

End With

End If

'CAE23

If Template = "EVALUATION REPORT CAE23" Then

Set wApp = CreateObject("Word.Application")
'wApp.Visible = True
Set wDoc = wApp.Documents.Open(ActiveWorkbook.Path & "" & "templates" & "/" & "EVALUATION REPORT CAE23.docx")

With wDoc
.Application.Selection.Find.Text = "<<NAME>>"
.Application.Selection.Find.Execute
.Application.Selection = StudentName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<GROUP>>"
.Application.Selection.Find.Execute
.Application.Selection = GroupName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<TEACHER>>"
.Application.Selection.Find.Execute
.Application.Selection = TeacherName
.Application.Selection.EndOf


.SaveAs (ActiveWorkbook.Path & "" & TeacherName & "") & GroupName & "" & StudentName & " " & FileYear

End With

End If

'CPE

If Template = "EVALUATION REPORT CPE" Then

Set wApp = CreateObject("Word.Application")
'wApp.Visible = True
Set wDoc = wApp.Documents.Open(ActiveWorkbook.Path & "" & "templates" & "/" & "EVALUATION REPORT CPE.docx")

With wDoc
.Application.Selection.Find.Text = "<<NAME>>"
.Application.Selection.Find.Execute
.Application.Selection = StudentName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<GROUP>>"
.Application.Selection.Find.Execute
.Application.Selection = GroupName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<TEACHER>>"
.Application.Selection.Find.Execute
.Application.Selection = TeacherName
.Application.Selection.EndOf


.SaveAs (ActiveWorkbook.Path & "" & TeacherName & "") & GroupName & "" & StudentName & " " & FileYear

End With

End If

'starters

If Template = "EVALUATION REPORT Starters" Then

Set wApp = CreateObject("Word.Application")
'wApp.Visible = True
Set wDoc = wApp.Documents.Open(ActiveWorkbook.Path & "" & "templates" & "/" & "EVALUATION REPORT Starters.docx")

With wDoc
.Application.Selection.Find.Text = "<<NAME>>"
.Application.Selection.Find.Execute
.Application.Selection = StudentName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<GROUP>>"
.Application.Selection.Find.Execute
.Application.Selection = GroupName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<TEACHER>>"
.Application.Selection.Find.Execute
.Application.Selection = TeacherName
.Application.Selection.EndOf


.SaveAs (ActiveWorkbook.Path & "" & TeacherName & "") & GroupName & "" & StudentName & " " & FileYear

End With

End If

'KET

If Template = "EVALUATION REPORT KET" Then

Set wApp = CreateObject("Word.Application")
'wApp.Visible = True
Set wDoc = wApp.Documents.Open(ActiveWorkbook.Path & "" & "templates" & "/" & "EVALUATION REPORT KET.docx")

With wDoc
.Application.Selection.Find.Text = "<<NAME>>"
.Application.Selection.Find.Execute
.Application.Selection = StudentName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<GROUP>>"
.Application.Selection.Find.Execute
.Application.Selection = GroupName
.Application.Selection.EndOf

.Application.Selection.Find.Text = "<<TEACHER>>"
.Application.Selection.Find.Execute
.Application.Selection = TeacherName
.Application.Selection.EndOf


.SaveAs (ActiveWorkbook.Path & "" & TeacherName & "") & GroupName & "" & StudentName & " " & FileYear

End With

End If



Call wApp.Quit
Next I

MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")

'Notify user in seconds
MsgBox "To create all these reports took " & MinutesElapsed, vbInformation

End Sub
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
Sort by date Sort by votes
First of all, when posting code, like this VBA, enclose it in [ CODE ][ /CODE ] tags and indent properly. This will make it easier for various programmers to follow the flow of your program.
 
Upvote 0
This might not speed things up much, but is neater code
Code: 
Sub Report_Generator()

    Dim wApp As Word.Application
    Dim wDoc As Word.Document
    Dim TeacherName As String
    Dim GroupName As String
    Dim StudentName As String
    Dim Template As String
    Dim FileYear As String
    Dim Answer As Integer
    
    Dim StartTime As Double
    Dim MinutesElapsed As String
    
    Answer = MsgBox("Are you sure you are ready to do this? Have you done all the necessary checks? Remember this will take a LONG time.", vbYesNo + vbQuestion, "Empty Sheet")
    
    If Answer = vbNo Then Exit Sub
    
    FileYear = InputBox("What academic year is it? e.g. 17-18")
    
    StartTime = Timer
    
    Sheets("Data").Select
    FinalRow = Range("A" & Rows.Count).End(xlUp).Row
        
    Set wApp = CreateObject("Word.Application")

    For i = 2 To FinalRow
        Sheets("Data").Select
        
        Range("A" & i).Copy Destination:=Sheets("Template").Range("A1")
        Range("B" & i & ":E" & i).Copy
        Sheets("Template").Select
        Range("A2").PasteSpecial Transpose:=True
        
        Range("A1:A3").Copy
        
        StudentName = Sheets("Template").Range("A1").Text
        GroupName = Sheets("Template").Range("A2").Text
        TeacherName = Sheets("Template").Range("A3").Text
        Template = Sheets("Template").Range("A4").Text
        
        If Dir((ActiveWorkbook.path) & "/" & TeacherName, vbDirectory) = "" Then
            MkDir (ActiveWorkbook.path) & "/" & TeacherName
        End If
        
        If Dir((ActiveWorkbook.path) & "/" & TeacherName & "/" & GroupName, vbDirectory) = "" Then
            MkDir (ActiveWorkbook.path) & "/" & TeacherName & "/" & GroupName
        End If
        

        Select Case Template
            Case "EVALUATION REPORT Movers & Flyers"
                Set wDoc = wApp.Documents.Open(ActiveWorkbook.path & "" & "templates" & "/" & "EVALUATION REPORT Movers & Flyers.docx")
            Case "EVALUATION REPORT 1st Primary"
                Set wDoc = wApp.Documents.Open(ActiveWorkbook.path & "" & "templates" & "/" & "EVALUATION REPORT 1st Primary.docx")
            Case "EVALUATION REPORT Infants"
                Set wDoc = wApp.Documents.Open(ActiveWorkbook.path & "" & "templates" & "/" & "EVALUATION REPORT Infants.docx")
            Case "EVALUATION REPORT PET1 BLAST"
                Set wDoc = wApp.Documents.Open(ActiveWorkbook.path & "" & "templates" & "/" & "EVALUATION REPORT PET1 BLAST.docx")
            Case "EVALUATION REPORT PET23"
                Set wDoc = wApp.Documents.Open(ActiveWorkbook.path & "" & "templates" & "/" & "EVALUATION REPORT PET23.docx")
        End Select
            
        With wDoc
            .Application.Selection.Find.Text = "<>"
            .Application.Selection.Find.Execute
            .Application.Selection = StudentName
            .Application.Selection.EndOf
            
            .Application.Selection.Find.Text = "<>"
            .Application.Selection.Find.Execute
            .Application.Selection = GroupName
            .Application.Selection.EndOf
            
            .Application.Selection.Find.Text = "<>"
            .Application.Selection.Find.Execute
            .Application.Selection = TeacherName
            .Application.Selection.EndOf
            
            .SaveAs (ActiveWorkbook.path & "" & TeacherName & "") & GroupName & "" & StudentName & "" & " " & FileYear
        End With
    Next i
    
    Call wApp.Quit
    
    MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
    
    'Notify user in seconds
    MsgBox "To create all these reports took " & MinutesElapsed, vbInformation
    
End Sub
You'll need to add the rest of the select cases, & also check the file paths as I suspect some of your separators have disappeared.
 
Upvote 0
On my old 2600K, 8GB RAM, HDD and my own modified code (almost like above), 1200 records took only 6,5 minutes.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question
I am trying to use a single work book with multiple sheets each sheet contains a different macro to generate a single word.doc template,
Replies
0
Views
300
anasha81
A
C
  • Question
VBA for decimals and saving
Replies
1
Views
408
Joe4
Joe4
O
  • Question
Change MS Word Doc Properties via MS Excel VBA Macro
Replies
3
Views
80
NdNoviceHlp
NdNoviceHlp
P
  • Question
Export data from Excel to Word template and save output as *.doc usiung VBA
Replies
0
Views
2K
Peter Ren
P
F
  • Solved
Filling out Text in Excel Cell Based on Highlighted Text in Microsoft Word
Replies
5
Views
698
NdNoviceHlp
NdNoviceHlp

Forum statistics

Threads
1,215,674
Messages
6,126,140
Members
449,294
Latest member
Jitesh_Sharma

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top