Why does Excel run slowly / unresponsively AFTER this macro has completed successfully?

derekpegg · Feb 19, 2009

I have a fairly large macro shown below which basically open a Word template, copies some named ranges in then completes a mail merge merging data from the workbook into the Word template. Finally it calls a simple Word macro to insert a table of contents into the document. It does a few other things besides but this is the main purpose. As you can probably tell, my coding skills are a long way short of most of the users of this forum and I'm sure there is much I can cut out or make more efficient. But the macro works and completes pretty quickly. My problem is that once it has finished (I have double checked it has finished by putting a quick msgbox at the very end to test it), that the workbook becomes incredible slow and unresponsive. It may take a couple of minutes until I can even select the Excel window and then it runs at a snails pace and simple (and usually very quick) macros such as worksheet_activate ones to set the zoom, for example, take an age as does even selecting a cell and being able to enter data anywhere in the workbook. I have always just killed the workbook with the task manager, but was wondering if there was a way to kick Excel back into life after it was done with this sub. It is the fact that Excel is still very slow AFTER finishing the sub completely that is puzzling me. I would have thought that once a sub completes excel should be back up to normal speed. Do I need to ‘release’ or ‘clear’ something to make this happen? Any help with this is very much appreciated.

Code:

Sub FullSetMerge()

Dim azz As String
azz = Environ("ComputerName")
If azz = "DPEGG" Then
Application.EnableCancelKey = xlInterrupt
Else
Application.EnableCancelKey = xlDisabled
End If

Dim WAVFile As String
Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_FILENAME = &H20000
Dim WinDirEnv As String
    WinDirEnv = Environ("Windir") + "\"
 
EnableSelection = xlNoRestrictions
ActiveSheet.Unprotect

Application.EnableEvents = False
     Application.ScreenUpdating = False
Sheets("Report Creation").Range("a7").Value = Sheets("home").Range("f1")
     Application.ScreenUpdating = False
Sheets("home").Unprotect
     Application.ScreenUpdating = False
Sheets("home").Range("f1").Value = 1
     Application.ScreenUpdating = False
Application.EnableEvents = True


Dim x
    For x = 1 To Sheets.Count
    'Sheets(x).Activate
     Application.ScreenUpdating = False
     Application.EnableEvents = False
            Sheets(x).Unprotect
    Next x
    
    Dim wx As Worksheet
For Each wx In ThisWorkbook.Worksheets
wx.ScrollArea = ""
Next wx
 
'*****add a reference to the MS Word Object Library (VB-Tools-References)*****
 
If Sheets("Report Creation").Range("f7") = 1 Then
On Error GoTo errHandler
Else
On Error Resume Next
End If

'DISABLE EXCEL UNNECESSARY FUNCTIONALITY THROUGHOUT PROCESS
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
  
'MESSAGE BOX TO ENSURE ALL FIELDS ENTERED
If Range("a6").Value = 0 Then
If MsgBox("It appears you have not completed all necessary sections.  Please check through the spreadsheet before continuing" & Sheets("Risk Profiling").Range("c218") & Sheets("Risk Profiling").Range("B218").Value & ".  Do you want to continue?", vbYesNo, "Pension Performance Analyser - Full Report Set") = vbNo Then GoTo Exitrun
End If
 
Dim starttime, endtime
starttime = Timer
 
'MESSAGE BOX TO ENSURE ALL OTHER WORD FILES ARE CLOSED
If MsgBox("Please ensure you have entered ALL necessary data and have no Word documents or templates open and that this file (Excel) is SAVED locally - not on a network drive " & Sheets("home").Range("b52") & ".  It is strongly recommended that you re-save this file immediately before creating this report.  Do you want to continue?", vbYesNo, "Pension Performance Analyser - Full Report Set") = vbNo Then GoTo Exitrun
 
'PLAY START SOUND
If Sheets("home").Range("A68").Value = "1" Then
WAVFile = WinDirEnv & "\..\PPR v11\images\inireport.wav"
Call PlaySound(WAVFile, 0&, SND_ASYNC Or SND_FILENAME)
           End If
 
'WAIT
Application.Wait Now + TimeValue("00:00:04")
 
'SHOW USERFORM
Application.WindowState = xlMinimized
UserForm4.Show vbModeless
DoEvents
 
 
  Sheets("Penalties & Initial Costs").Select
  ActiveSheet.Unprotect

 Dim rRow As Long
    rRow = Sheets("Penalties & Initial Costs").Range("A80").End(xlUp).Row
    For rRow = rRow To 1 Step -1
        If Sheets("Penalties & Initial Costs").Cells(rRow, 1) = "W" Then Sheets("Penalties & Initial Costs").rows(rRow).Hidden = True
    Next rRow
    
       If Sheets("home").Range("f1").Value = 0 Then
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=False
End If
 
 
'Tidy FP graph footers

Dim finish As Boolean
Dim zi As Integer
Dim zt As Integer

zi = 1
zt = 850
finish = False
    
    Do Until finish = True
    For zi = 1 To zt
        If Sheets("Fund Performance").Range("a" & zi) = "R" Then Sheets("Fund Performance").rows(zi).Hidden = True
        If Sheets("Fund Performance").Range("a" & zi) = "Q" Then Sheets("Fund Performance").rows(zi).Hidden = False
        If zi = zt Then
           finish = True
        End If
    Next zi
    Loop
 

'Make sure worksheet for alloc is visible
If Worksheets("Portfolio Allocations").Visible = False Then
Worksheets("Portfolio Allocations").Visible = True
End If

'Make sure worksheet for fund charges is visible
If Worksheets("Fund Charges").Visible = False Then
Worksheets("Fund Charges").Visible = True
End If

'Make sure worksheet for GMP is visible
If Worksheets("GMP").Visible = False Then
Worksheets("GMP").Visible = True
End If

'Make sure worksheet for Pension Priorities is visible
If Worksheets("Pension Priorities").Visible = False Then
Worksheets("Pension Priorities").Visible = True
End If

'Make sure worksheet for S2P Critical Yield is visible
If Worksheets("S2P Critical Yield").Visible = False Then
Worksheets("S2P Critical Yield").Visible = True
End If

'Make sure tracking graph is visible
If Worksheets("Portfolio 1 Tracking").Visible = False Then
Worksheets("Portfolio 1 Tracking").Visible = True
End If

If Worksheets("Portfolio 2 Tracking").Visible = False Then
Worksheets("Portfolio 2 Tracking").Visible = True
End If

If Worksheets("Portfolio 3 Tracking").Visible = False Then
Worksheets("Portfolio 3 Tracking").Visible = True
End If

If Worksheets("Portfolio 4 Tracking").Visible = False Then
Worksheets("Portfolio 4 Tracking").Visible = True
End If

If Worksheets("Portfolio 5 Tracking").Visible = False Then
Worksheets("Portfolio 5 Tracking").Visible = True
End If

If Worksheets("Main Portfolio Tracking").Visible = False Then
Worksheets("Main Portfolio Tracking").Visible = True
End If

'Make sure sheet for PG1N is visible
If Sheets("PG1N").Visible = False Then
Sheets("PG1N").Visible = True
End If

'Make sure sheet for PG2N is visible
If Sheets("PG2N").Visible = False Then
Sheets("PG2N").Visible = True
End If

'Make sure sheet for PG3N is visible
If Sheets("PG3N").Visible = False Then
Sheets("PG3N").Visible = True
End If

'Make sure sheet for PG4N is visible
If Sheets("PG4N").Visible = False Then
Sheets("PG4N").Visible = True
End If

'Make sure sheet for PG5N is visible
If Sheets("PG5N").Visible = False Then
Sheets("PG5N").Visible = True
End If

'Make sure worksheet for Sector Chart is visible
If Sheets("Sector Chart").Visible = False Then
Sheets("Sector Chart").Visible = True
End If

'SET ITEMS
Dim FileBerger As String
Dim TemplateBerger As String
Dim appWd As Word.Application
Dim Myref As String
Dim fs
'Dim WinDirEnv As String
 
'CREATE A NEW WORD FILE
Set appWd = CreateObject("Word.Application")
'appWd.WindowState = wdWindowStateMinimize

appWd.Visible = False
 
'SET WHERE WORD AND EXCEL FILES ARE LOCATED
WinDirEnv = Environ("Windir") + "\"
FileBerger = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
If Sheets("Report Creation").Range("e8").Value = 1 Then

If Sheets("Remuneration & Client Details").Range("i5") = "SIS" Then
TemplateBerger = WinDirEnv & "\..\PPR v11\PPR Report Set Auto SIS - MM.dot"
Else
TemplateBerger = WinDirEnv & "\..\PPR v11\PPR Report Set Auto - MM.dot"
End If

Else

If Sheets("Remuneration & Client Details").Range("i5") = "SIS" Then
TemplateBerger = WinDirEnv & "\..\PPR v11\PPR Report Set Auto SIS - MM noIR.dot"
Else
TemplateBerger = WinDirEnv & "\..\PPR v11\PPR Report Set Auto - MM noIR.dot"
End If


End If
 
'OPEN WORD TEMPLATE
appWd.Documents.Add Template:=TemplateBerger, NewTemplate:=False
 
' ************ THIS DOES ALL THE EASY TABLES ************
Dim myCrit(1 To 23) As String ' Declaring array and setting bounds
Dim i As Integer
Dim myFlag As Boolean
myFlag = False
 
 'To fill array with values
   myCrit(1) = "cp"
   myCrit(2) = "pen"
   myCrit(3) = "inc"
   myCrit(4) = "cyone"
   myCrit(5) = "pclsone"
   myCrit(6) = "db"
   myCrit(7) = "fsec"
   myCrit(8) = "fptwo"
   myCrit(9) = "proa"
   myCrit(10) = "iap"
   myCrit(11) = "adsy"
   myCrit(12) = "inflex"
   myCrit(13) = "aac"
   myCrit(14) = "pd"
   myCrit(15) = "alloc"
   myCrit(16) = "S2PCYT"
   myCrit(17) = "amcc"
   myCrit(18) = "anaaa2"
   myCrit(19) = "anaaa3"
   myCrit(20) = "PPrio"
   myCrit(21) = "rbo"
   myCrit(22) = "newalloc"
   myCrit(23) = "coninout"
   
Do Until myFlag = True
For i = 1 To 23

'COPY RANGE FROM EXCEL
Application.Goto Reference:=myCrit(i)
   Selection.Copy
 
'FIND BOOKMARK IN WORD
appWd.Selection.Goto What:=wdGoToBookmark, Name:=myCrit(i)
 
'PASTE RANGE
appWd.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:= _
wdInLine, DisplayAsIcon:=False
 
'RESIZE RANGE
appWd.Selection.MoveLeft Unit:=wdCharacter, Count:=1
appWd.Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
appWd.Selection.InlineShapes(1).LockAspectRatio = msoFalse

appWd.Selection.InlineShapes(1).ScaleHeight = 84.8
appWd.Selection.InlineShapes(1).ScaleWidth = 76

 
   If i = 23 Then
       myFlag = True
   End If
 
Next i
Loop

'THIS DOES THE FPONE TABLE

'COPY RANGE FROM EXCEL
Application.Goto Reference:="fpone"
   Selection.Copy
 
'FIND BOOKMARK IN WORD
appWd.Selection.Goto What:=wdGoToBookmark, Name:="fpone"
 
'PASTE RANGE
appWd.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:= _
wdInLine, DisplayAsIcon:=False
 
'RESIZE RANGE
appWd.Selection.MoveLeft Unit:=wdCharacter, Count:=1
appWd.Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
appWd.Selection.InlineShapes(1).LockAspectRatio = msoFalse

appWd.Selection.InlineShapes(1).ScaleHeight = 81.7
appWd.Selection.InlineShapes(1).ScaleWidth = 76

'PLAY WAIT SOUND
If Sheets("home").Range("A68").Value = "1" Then
Sheets("Report Creation").Select
WAVFile = WinDirEnv & "\..\PPR v11\images\building.wav"
Call PlaySound(WAVFile, 0&, SND_ASYNC Or SND_FILENAME)
           End If
           
           'WAIT
Application.Wait Now + TimeValue("00:00:04")

 
' ************ THIS DOES THE IF TABLES ************
 
Dim myCriteria(1 To 25) As String ' Declaring array and setting bounds
Dim n As Integer
Dim myFlag2 As Boolean
Dim test1 As String
myFlag2 = False
 
'  To fill array with values
   myCriteria(1) = "pclspro"
   myCriteria(2) = "cytwo"
   myCriteria(3) = "fpfive"
   myCriteria(4) = "fpsix"
   myCriteria(5) = "fpseven"
   myCriteria(6) = "fpov"
   myCriteria(7) = "fpthree"
   myCriteria(8) = "fpfour"
   myCriteria(9) = "fpeight"
   myCriteria(10) = "fpnine"
   myCriteria(11) = "wpt"
   myCriteria(12) = "at"
   myCriteria(13) = "tli"
   myCriteria(14) = "tdes"
   myCriteria(15) = "GMP"
   myCriteria(16) = "WPAA"
   myCriteria(17) = "gar"
   myCriteria(18) = "erp"
   myCriteria(19) = "mvr"
   myCriteria(20) = "wop"
   myCriteria(21) = "life"
   myCriteria(22) = "cytwonaf"
   myCriteria(23) = "cyonenaf"
   myCriteria(24) = "tpcls"
   myCriteria(25) = "wrapben"

Do Until myFlag2 = True
For n = 1 To 25
 
'DECIDE IF TO INCLUDE RANGE
Application.Goto Reference:=myCriteria(n) & "d"
If Selection.Value = 1 Then
 

'COPY RANGE FROM EXCEL
Application.Goto Reference:=myCriteria(n)
   Selection.Copy
 
'FIND BOOKMARK IN WORD
appWd.Selection.Goto What:=wdGoToBookmark, Name:=myCriteria(n)
 
'PASTE RANGE
appWd.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:= _
wdInLine, DisplayAsIcon:=False
 
'RESIZE RANGE
appWd.Selection.MoveLeft Unit:=wdCharacter, Count:=1
appWd.Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
appWd.Selection.InlineShapes(1).LockAspectRatio = msoFalse
appWd.Selection.InlineShapes(1).ScaleHeight = 84.8
appWd.Selection.InlineShapes(1).ScaleWidth = 76
 
'OR IF NOT TO BE INCLUDED

Else:

If myCriteria(n) <> "wrapben" Then

appWd.Selection.Goto What:=wdGoToBookmark, Name:=myCriteria(n)
appWd.Selection.Delete Unit:=wdCharacter, Count:=1
 
 End If

End If
 
   If n = 25 Then
       myFlag2 = True
   End If
 
Next n
Loop

'PLAY WAIT SOUND
If Sheets("home").Range("A68").Value = "1" Then
Sheets("Report Creation").Select
WAVFile = WinDirEnv & "\..\PPR v11\images\building.wav"
Call PlaySound(WAVFile, 0&, SND_ASYNC Or SND_FILENAME)
           End If
           
           'WAIT
Application.Wait Now + TimeValue("00:00:02")

 
' ************ THIS DOES THE DECISION TABLES ************
 
If Sheets("Report Creation").Range("e8") = 1 Then
 
 
Dim myCriteriaa(1 To 3) As String ' Declaring array and setting bounds
Dim p As Integer
Dim ******** As Integer
Dim ****e As Integer
Dim myFlag3 As Boolean
myFlag3 = False
 
'To fill array with values
   myCriteriaa(1) = "ppa"
   myCriteriaa(2) = "sectiona"
   myCriteriaa(3) = "eppa"

Do Until myFlag3 = True
For p = 1 To 3
 
'DECIDE IF TO INCLUDE RANGE
******** = Len(myCriteriaa(p))
****e = ******** - 1
Myref = Left(myCriteriaa(p), ****e)
 
Application.Goto Reference:=myCriteriaa(p)
If Selection.Value = 1 Then
 
Application.Goto Reference:=Myref
   Selection.Copy
 
'FIND BOOKMARK IN WORD
appWd.Selection.Goto What:=wdGoToBookmark, Name:=myCriteriaa(p)
 
'PASTE RANGE
appWd.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:= _
wdInLine, DisplayAsIcon:=False
 
'RESIZE RANGE
appWd.Selection.MoveLeft Unit:=wdCharacter, Count:=1
appWd.Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
appWd.Selection.InlineShapes(1).LockAspectRatio = msoFalse
appWd.Selection.InlineShapes(1).ScaleHeight = 84.8
appWd.Selection.InlineShapes(1).ScaleWidth = 76
 
 
 Else: appWd.Selection.Goto What:=wdGoToBookmark, Name:=myCriteriaa(p)
appWd.Selection.Delete Unit:=wdCharacter, Count:=1

End If
 
   If p = 3 Then
       myFlag3 = True
   End If
 
Next p
Loop

End If
 
' ************ THIS DOES ALL THE GRAPHS ************

'Make sure sheet for portfolio graph is visible
If Sheets("Portfolio Graph (pensions)").Visible = False Then
Sheets("Portfolio Graph (pensions)").Visible = True
End If

Dim myGraphSheet(1 To 15) As String ' Declaring array and setting bounds
Dim myGraphRange(1 To 15) As String ' Declaring array and setting bounds
Dim bollocks2 As Integer
Dim ****e2 As Integer
Dim myref2 As String
Dim q As Integer
Dim myFlag4 As Boolean
myFlag4 = False
 
 'To fill array with values
   myGraphSheet(1) = "FP Graph 1"
   'myGraphSheet(2) = "FP Graph 2"
   myGraphSheet(2) = "FP Graph 3"
   myGraphSheet(3) = "Asset Allocation Comp"
   'myGraphSheet(5) = "Asset Allocation Difs"
   myGraphSheet(4) = "Portfolio Graph (pensions)"
    myGraphSheet(5) = "Portfolio Graph (pensions)"
   myGraphSheet(6) = "Pension Projection Graph"
   myGraphSheet(7) = "Portfolio Graph (pensions)"
      myGraphSheet(8) = "PT Graph Growth Needed"
            myGraphSheet(9) = "PT Graph Conts Needed"
      myGraphSheet(10) = "PG1N"
   myGraphSheet(11) = "PG2N"
   myGraphSheet(12) = "PG3N"
   myGraphSheet(13) = "PG4N"
   myGraphSheet(14) = "PG5N"
      myGraphSheet(15) = "Sector Chart"
   

   myGraphRange(1) = "fpgone"
   'myGraphRange(2) = "fpgtwo"
   myGraphRange(2) = "fpgthree"
   myGraphRange(3) = "aacg"
   'myGraphRange(5) = "aacd"
   myGraphRange(4) = "pprgraph"
    myGraphRange(5) = "graph"
   myGraphRange(6) = "iag"
   myGraphRange(7) = "irpg"
      myGraphRange(8) = "PTgraphgrowth"
            myGraphRange(9) = "PTgraphconts"
   myGraphRange(10) = "PG1N"
   myGraphRange(11) = "PG2N"
   myGraphRange(12) = "PG3N"
   myGraphRange(13) = "PG4N"
   myGraphRange(14) = "PG5N"
      myGraphRange(15) = "schart"

Do Until myFlag4 = True
For q = 1 To 15
 
If myGraphRange(q) = "pprgraph" Or myGraphRange(q) = "graph" Then
 
'COPY CHART FROM EXCEL
Application.Sheets(myGraphSheet(q)).Select
Application.ActiveChart.ChartArea.Select
Application.ActiveChart.ChartArea.Copy
 
'FIND BOOKMARK IN WORD
appWd.Selection.Goto What:=wdGoToBookmark, Name:=myGraphRange(q)
 
'PASTE CHART
appWd.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:= _
wdInLine, DisplayAsIcon:=False
 
'RESIZE CHART
appWd.Selection.MoveLeft Unit:=wdCharacter, Count:=1
appWd.Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
appWd.Selection.InlineShapes(1).LockAspectRatio = msoTrue
appWd.Selection.InlineShapes(1).Height = 183.4
appWd.Selection.InlineShapes(1).Width = 382.4
End If

If myGraphRange(q) = "irpg" Then

If Sheets("Report Creation").Range("e8") = 1 Then
 
'COPY CHART FROM EXCEL
Application.Sheets(myGraphSheet(q)).Select
Application.ActiveChart.ChartArea.Select
Application.ActiveChart.ChartArea.Copy
 
'FIND BOOKMARK IN WORD
appWd.Selection.Goto What:=wdGoToBookmark, Name:=myGraphRange(q)
 
'PASTE CHART
appWd.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:= _
wdInLine, DisplayAsIcon:=False
 
'RESIZE CHART
appWd.Selection.MoveLeft Unit:=wdCharacter, Count:=1
appWd.Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
appWd.Selection.InlineShapes(1).LockAspectRatio = msoTrue
appWd.Selection.InlineShapes(1).Height = 183.4
appWd.Selection.InlineShapes(1).Width = 382.4
End If

End If
    
If myGraphRange(q) = "niag" Or myGraphRange(q) = "iag" Or myGraphRange(q) = "PTgraphgrowth" Or myGraphRange(q) = "PTgraphconts" Then
 
'COPY CHART FROM EXCEL
Application.Sheets(myGraphSheet(q)).Select
Application.ActiveChart.ChartArea.Select
Application.ActiveChart.ChartArea.Copy
 
'FIND BOOKMARK IN WORD
appWd.Selection.Goto What:=wdGoToBookmark, Name:=myGraphRange(q)
 
'PASTE CHART
appWd.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:= _
wdInLine, DisplayAsIcon:=False
 
'RESIZE CHART
appWd.Selection.MoveLeft Unit:=wdCharacter, Count:=1
appWd.Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
appWd.Selection.InlineShapes(1).LockAspectRatio = msoFalse
appWd.Selection.InlineShapes(1).Height = 270.15
appWd.Selection.InlineShapes(1).Width = 439.65
End If

'If PGN chart
If myGraphRange(q) = "PG1N" Or myGraphRange(q) = "PG2N" Or myGraphRange(q) = "PG3N" Or myGraphRange(q) = "PG4N" Or myGraphRange(q) = "PG5N" Then
 
'COPY CHART FROM EXCEL
Application.Sheets(myGraphSheet(q)).Select
Application.ActiveChart.ChartArea.Select
Application.ActiveChart.ChartArea.Copy
 
'FIND BOOKMARK IN WORD
appWd.Selection.Goto What:=wdGoToBookmark, Name:=myGraphRange(q)
 
'PASTE CHART
appWd.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:= _
wdInLine, DisplayAsIcon:=False
 
'RESIZE CHART
appWd.Selection.MoveLeft Unit:=wdCharacter, Count:=1
appWd.Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
appWd.Selection.InlineShapes(1).LockAspectRatio = msoTrue
appWd.Selection.InlineShapes(1).Height = 132.1
appWd.Selection.InlineShapes(1).Width = 275.28
End If
 
If myGraphRange(q) = "fpgone" Or myGraphRange(q) = "fpgtwo" Or myGraphRange(q) = "fpgthree" Or myGraphRange(q) = "aacg" Or myGraphRange(q) = "aacd" Or myGraphRange(q) = "schart" Then
 
'COPY CHART FROM EXCEL
Application.Sheets(myGraphSheet(q)).Select
Application.ActiveChart.ChartArea.Select
Application.ActiveChart.ChartArea.Copy
 
'FIND BOOKMARK IN WORD
appWd.Selection.Goto What:=wdGoToBookmark, Name:=myGraphRange(q)
 
'PASTE CHART
appWd.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:= _
wdInLine, DisplayAsIcon:=False
 
'RESIZE CHART
appWd.Selection.MoveLeft Unit:=wdCharacter, Count:=1
appWd.Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
appWd.Selection.InlineShapes(1).LockAspectRatio = msoTrue
appWd.Selection.InlineShapes(1).Height = 303.3
appWd.Selection.InlineShapes(1).Width = 443.9
End If
 
    If q = 15 Then
        myFlag4 = True
    End If
 
Next q
Loop

If Sheets("Report Creation").Range("e8").Value = 1 Then

'DECIDE IF TO INCLUDE PG 1
 
    If Sheets("Report Creation").Range("d92").Value = 1 Then
 
'COPY CHART FROM EXCEL
Application.Sheets("Portfolio 1 Tracking").Select
ActiveSheet.ChartObjects("Chart 2").Activate
Application.ActiveChart.ChartArea.Select
Application.ActiveChart.ChartArea.Copy
 
'FIND BOOKMARK IN WORD
appWd.Selection.Goto What:=wdGoToBookmark, Name:="pg1"
 
'PASTE CHART
appWd.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:= _
wdInLine, DisplayAsIcon:=False
 
'RESIZE CHART
appWd.Selection.MoveLeft Unit:=wdCharacter, Count:=1
appWd.Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
appWd.Selection.InlineShapes(1).LockAspectRatio = msoFalse
appWd.Selection.InlineShapes(1).Height = 202.1
appWd.Selection.InlineShapes(1).Width = 462.05
       End If
       
       'DECIDE IF TO INCLUDE PG 2
 
    If Sheets("Report Creation").Range("d93").Value = 1 Then
 
'COPY CHART FROM EXCEL
Application.Sheets("Portfolio 2 Tracking").Select
ActiveSheet.ChartObjects("Chart 2").Activate
Application.ActiveChart.ChartArea.Select
Application.ActiveChart.ChartArea.Copy
 
'FIND BOOKMARK IN WORD
appWd.Selection.Goto What:=wdGoToBookmark, Name:="pg2"
 
'PASTE CHART
appWd.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:= _
wdInLine, DisplayAsIcon:=False
 
'RESIZE CHART
appWd.Selection.MoveLeft Unit:=wdCharacter, Count:=1
appWd.Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
appWd.Selection.InlineShapes(1).LockAspectRatio = msoFalse
appWd.Selection.InlineShapes(1).Height = 202.1
appWd.Selection.InlineShapes(1).Width = 462.05
       End If
       
       'DECIDE IF TO INCLUDE PG 3
 
    If Sheets("Report Creation").Range("d94").Value = 1 Then
 
'COPY CHART FROM EXCEL
Application.Sheets("Portfolio 3 Tracking").Select
ActiveSheet.ChartObjects("Chart 2").Activate
Application.ActiveChart.ChartArea.Select
Application.ActiveChart.ChartArea.Copy
 
'FIND BOOKMARK IN WORD
appWd.Selection.Goto What:=wdGoToBookmark, Name:="pg3"
 
'PASTE CHART
appWd.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:= _
wdInLine, DisplayAsIcon:=False
 
'RESIZE CHART
appWd.Selection.MoveLeft Unit:=wdCharacter, Count:=1
appWd.Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
appWd.Selection.InlineShapes(1).LockAspectRatio = msoFalse
appWd.Selection.InlineShapes(1).Height = 202.1
appWd.Selection.InlineShapes(1).Width = 462.05
       End If
       
       'DECIDE IF TO INCLUDE PG 4
 
    If Sheets("Report Creation").Range("d95").Value = 1 Then
 
'COPY CHART FROM EXCEL
Application.Sheets("Portfolio 4 Tracking").Select
ActiveSheet.ChartObjects("Chart 2").Activate
Application.ActiveChart.ChartArea.Select
Application.ActiveChart.ChartArea.Copy
 
'FIND BOOKMARK IN WORD
appWd.Selection.Goto What:=wdGoToBookmark, Name:="pg4"
 
'PASTE CHART
appWd.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:= _
wdInLine, DisplayAsIcon:=False
 
'RESIZE CHART
appWd.Selection.MoveLeft Unit:=wdCharacter, Count:=1
appWd.Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
appWd.Selection.InlineShapes(1).LockAspectRatio = msoFalse
appWd.Selection.InlineShapes(1).Height = 202.1
appWd.Selection.InlineShapes(1).Width = 462.05
       End If
       
       'DECIDE IF TO INCLUDE PG 5
 
    If Sheets("Report Creation").Range("d96").Value = 1 Then
 
'COPY CHART FROM EXCEL
Application.Sheets("Portfolio 5 Tracking").Select
ActiveSheet.ChartObjects("Chart 2").Activate
Application.ActiveChart.ChartArea.Select
Application.ActiveChart.ChartArea.Copy
 
'FIND BOOKMARK IN WORD
appWd.Selection.Goto What:=wdGoToBookmark, Name:="pg5"
 
'PASTE CHART
appWd.Selection.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:= _
wdInLine, DisplayAsIcon:=False
 
'RESIZE CHART
appWd.Selection.MoveLeft Unit:=wdCharacter, Count:=1
appWd.Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
appWd.Selection.InlineShapes(1).LockAspectRatio = msoFalse
appWd.Selection.InlineShapes(1).Height = 202.1
appWd.Selection.InlineShapes(1).Width = 462.05
       End If
       
End If
 
'HIDE 'PORTFOLIO ALLOCATION' SHEET

If Worksheets("Portfolio Allocations").Visible = True Then
Worksheets("Portfolio Allocations").Visible = False
End If
 
'UNHIDE PRACTICE DETAILS SHEET
If Worksheets("Practice Details").Visible = False Then
Worksheets("Practice Details").Visible = True
End If
 
    'INSERT LOGO 1
    On Error GoTo LogoHandler
 Sheets("Practice Details").Select
ActiveSheet.Shapes("logo").Select
    Selection.Copy
 
'FIND BOOKMARK 1 IN WORD
appWd.Selection.Goto What:=wdGoToBookmark, Name:="logo1"
 
'PASTE RANGE 1
appWd.Selection.Paste
If Worksheets("Report Creation").Range("C8").Value = 1 Then
appWd.Selection.ShapeRange.IncrementLeft 80
appWd.Selection.ShapeRange.IncrementTop -20
End If
 
            'INSERT LOGO 2
 Sheets("Practice Details").Select
ActiveSheet.Shapes("logo").Select
    Selection.Copy
 
'FIND BOOKMARK 2 IN WORD
appWd.Selection.Goto What:=wdGoToBookmark, Name:="logo2"
 
'PASTE RANGE 2
appWd.Selection.Paste
If Worksheets("Report Creation").Range("C8").Value = 1 Then
appWd.Selection.ShapeRange.IncrementLeft 74.1
appWd.Selection.ShapeRange.IncrementTop -20
End If

If Sheets("Report Creation").Range("e8").Value = 1 Then
 
            'INSERT LOGO 3
 Sheets("Practice Details").Select
ActiveSheet.Shapes("logo").Select
    Selection.Copy
 
'FIND BOOKMARK 3 IN WORD
appWd.Selection.Goto What:=wdGoToBookmark, Name:="logo3"
 
'PASTE RANGE 3
appWd.Selection.Paste
If Worksheets("Report Creation").Range("C8").Value = 1 Then
appWd.Selection.ShapeRange.IncrementLeft 80
appWd.Selection.ShapeRange.IncrementTop -20
End If

End If

            'INSERT LOGO 4
 Sheets("Practice Details").Select
ActiveSheet.Shapes("logo").Select
    Selection.Copy
 
'FIND BOOKMARK 4 IN WORD
appWd.Selection.Goto What:=wdGoToBookmark, Name:="logo4"
 
'PASTE RANGE 4
appWd.Selection.Paste
If Worksheets("Report Creation").Range("C8").Value = 1 Then
appWd.Selection.ShapeRange.IncrementLeft 80
appWd.Selection.ShapeRange.IncrementTop -20
End If

On Error GoTo errHandler
 
'HIDE PRACTICE DETAILS SHEET
If Worksheets("Practice Details").Visible = True Then
Worksheets("Practice Details").Visible = False
End If

'HIDE COST TABLES SHEET
If Worksheets("Fund Charges").Visible = True Then
Worksheets("Fund Charges").Visible = False
End If

'HIDE GMP SHEET
If Worksheets("GMP").Visible = True Then
Worksheets("GMP").Visible = False
End If

'HIDE PENSION PRIORITIES SHEET
If Worksheets("Pension Priorities").Visible = True Then
Worksheets("Pension Priorities").Visible = False
End If

'HIDE S2P Critical Yield SHEET
If Worksheets("S2P Critical Yield").Visible = True Then
Worksheets("S2P Critical Yield").Visible = False
End If

'Make sure worksheet for Sector Chart is hidden
If Sheets("Sector Chart").Visible = True Then
Sheets("Sector Chart").Visible = False
End If

'Make sure worksheet for Portfolio Graph (Pensions) is hidden
If Sheets("Portfolio Graph (pensions)").Visible = True Then
Sheets("Portfolio Graph (pensions)").Visible = False
End If

'PLAY WAIT SOUND
If Sheets("home").Range("A68").Value = "1" Then
Sheets("Report Creation").Select
WAVFile = WinDirEnv & "\..\PPR v11\images\building.wav"
Call PlaySound(WAVFile, 0&, SND_ASYNC Or SND_FILENAME)
           End If
           
           'WAIT
Application.Wait Now + TimeValue("00:00:02")

'RUN MAIL MERGE
appWd.ActiveDocument.MailMerge.OpenDataSource Name:= _
FileBerger, _
ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
AddToRecentFiles:=True, PasswordDocument:="", PasswordTemplate:="", _
WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
Format:=wdOpenFormatAuto, Connection:= _
"DSN=Excel Files;DBQ=" & FileBerger & ";DriverId=790;MaxBufferSize=8192;PageTimeout=3;ConnectionTimeout=6;CommandTimeout=6;" _
, SQLStatement:="SELECT * FROM `AAAMerge`", SQLStatement1:=""
appWd.Visible = True
appWd.Activate
    With appWd.ActiveDocument.MailMerge
        .Destination = wdSendToNewDocument
        .MailAsAttachment = False
        .MailAddressFieldName = ""
        .MailSubject = ""
        .SuppressBlankLines = True
        With .DataSource
            .FirstRecord = 1
            .LastRecord = 1
        End With
        .Execute Pause:=True
    End With
    
        'PLAY WAIT SOUND
    If Sheets("home").Range("A68").Value = "1" Then
Sheets("Report Creation").Select
WAVFile = WinDirEnv & "\..\PPR v11\images\building.wav"
Call PlaySound(WAVFile, 0&, SND_ASYNC Or SND_FILENAME)
           End If
           
           'WAIT
Application.Wait Now + TimeValue("00:00:02")
           
           On Error Resume Next

'HIDE Portfolio Tracking Sheets
If Worksheets("Portfolio 1 Tracking").Visible = True Then
Worksheets("Portfolio 1 Tracking").Visible = False
End If

If Worksheets("Portfolio 2 Tracking").Visible = True Then
Worksheets("Portfolio 2 Tracking").Visible = False
End If

If Worksheets("Portfolio 3 Tracking").Visible = True Then
Worksheets("Portfolio 3 Tracking").Visible = False
End If

If Worksheets("Portfolio 4 Tracking").Visible = True Then
Worksheets("Portfolio 4 Tracking").Visible = False
End If

If Worksheets("Portfolio 5 Tracking").Visible = True Then
Worksheets("Portfolio 5 Tracking").Visible = False
End If

If Worksheets("Main Portfolio Tracking").Visible = True Then
Worksheets("Main Portfolio Tracking").Visible = False
End If

'Make sure worksheet for Sector Chart is hidden
If Sheets("Sector Chart").Visible = True Then
Sheets("Sector Chart").Visible = False
End If

'Make sure sheet for PG1N is hidden
If Sheets("PG1N").Visible = True Then
Sheets("PG1N").Visible = False
End If

'Make sure sheet for PG2N is hidden
If Sheets("PG2N").Visible = True Then
Sheets("PG2N").Visible = False
End If

'Make sure sheet for PG3N is hidden
If Sheets("PG3N").Visible = True Then
Sheets("PG3N").Visible = False
End If

'Make sure sheet for PG4N is hidden
If Sheets("PG4N").Visible = True Then
Sheets("PG4N").Visible = False
End If

'Make sure sheet for PG5N is hidden
If Sheets("PG5N").Visible = True Then
Sheets("PG5N").Visible = False
End If

On Error GoTo errHandler
    
'HIDE WORD ASAP - RELOAD USERFORM
Application.ScreenUpdating = True
Application.EnableEvents = True
Unload UserForm4
Sheets("Report Creation").Select
UserForm4.Show vbModeless
DoEvents
appWd.WindowState = wdWindowStateMinimize
Application.WindowState = xlMaximized
Application.Visible = True
Application.ScreenUpdating = False
Application.EnableEvents = False
appWd.WindowState = wdWindowStateMinimize
    
'CLOSE WORD TEMPLATE KEEPING MERGED FILE OPEN
appWd.Documents(2).Close False
 
'REMOVE LINKS
Dim aField As Object
 
   For Each aField In appWd.ActiveDocument.Fields
        aField.Locked = True
   Next aField
    
'CLEAR CLIPBOARD
Application.CutCopyMode = False
    
'INSERT TABLE OF CONTENTS
appWd.Selection.MoveUp Unit:=wdLine, Count:=500
appWd.Selection.MoveDown Unit:=wdLine, Count:=39
appWd.Run "mofo"
 
 If Worksheets("User Case Notes").Range("H5").Value = 1 Then

If Worksheets("User Case Notes").Range("g9").Value = 1 Then
Dim notea As String
notea = vbCrLf & vbCrLf & Worksheets("User Case Notes").Range("i9")
Else:
notea = ""
End If

If Worksheets("User Case Notes").Range("h9").Value = 1 Then
Dim noteb As String
noteb = vbCrLf & vbCrLf & Worksheets("User Case Notes").Range("j9")
Else:
noteb = ""
End If

If Worksheets("User Case Notes").Range("g10").Value = 1 Then
Dim notec As String
notec = vbCrLf & vbCrLf & Worksheets("User Case Notes").Range("i10")
Else:
notec = ""
End If

If Worksheets("User Case Notes").Range("h10").Value = 1 Then
Dim noted As String
noted = vbCrLf & vbCrLf & Worksheets("User Case Notes").Range("i10")
Else:
noted = ""
End If

If Worksheets("User Case Notes").Range("g11").Value = 1 Then
Dim notee As String
notee = vbCrLf & vbCrLf & Worksheets("User Case Notes").Range("i11")
Else:
notee = ""
End If

If Worksheets("User Case Notes").Range("h11").Value = 1 Then
Dim notef As String
notef = vbCrLf & vbCrLf & Worksheets("User Case Notes").Range("i11")
Else:
notef = ""
End If

If Worksheets("User Case Notes").Range("g12").Value = 1 Then
Dim noteg As String
noteg = vbCrLf & vbCrLf & Worksheets("User Case Notes").Range("i12")
Else:
noteg = ""
End If

If Worksheets("User Case Notes").Range("h12").Value = 1 Then
Dim noteh As String
noteh = vbCrLf & vbCrLf & Worksheets("User Case Notes").Range("i12")
Else:
noteh = ""
End If

If Worksheets("User Case Notes").Range("g13").Value = 1 Then
Dim notei As String
notei = vbCrLf & vbCrLf & Worksheets("User Case Notes").Range("i13")
Else:
notei = ""
End If

If Worksheets("User Case Notes").Range("h13").Value = 1 Then
Dim notej As String
notej = vbCrLf & vbCrLf & Worksheets("User Case Notes").Range("i13")
Else:
notej = ""
End If

MsgBox "User Case Notes For " & Worksheets("Remuneration & Client Details").Range("f20") & ":" & notea & noteb & notec & noted & notee & notef & noteg & noteh & notei & notej, , "Pension Performance Analyser - Full Report Set"

End If
 
 'PLAY FINISH SOUND
Sheets("Report Creation").Select
ActiveSheet.Unprotect
If Sheets("home").Range("A68").Value = "1" Then
WAVFile = WinDirEnv & "\..\PPR v11\images\reportsetcomplete.wav"
Call PlaySound(WAVFile, 0&, SND_ASYNC Or SND_FILENAME)
End If

'HIDE USERFORM
Unload UserForm4
 
'MAKE WORD FILE VISIBLE
appWd.WindowState = wdWindowStateMaximize
Application.WindowState = xlMinimized
appWd.Visible = True
 
'CLEAR ITEMS
Set appWd = Nothing

Application.EnableEvents = False
Sheets("home").Unprotect
Sheets("home").Range("f1").Value = Sheets("Report Creation").Range("a7")

Sheets("Report Creation").Range("b6").Select

                           If Sheets("home").Range("f1").Value = 0 Then
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=False
Else: ActiveSheet.Unprotect
End If
        
        If Worksheets("home").Range("F1").Value = 0 Then
EnableSelection = xlUnlockedCells
End If

'REENABLE PROPER EXCEL FUNCTIONALITY
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

End Sub

RoryA · Feb 20, 2009

I would guess it is the connection back from Word to the workbook that is the cause of the slowdown. If you comment out the section that does the actual merge, do you still have the same symptoms?

derekpegg · Feb 20, 2009

Just tried that and no joy - still unresponsive after commenting out mail merge sections.

I then tried a step further with no mail merge and no named ranges copied and pasted into the Word template and this solves the problem - it completes and is fine.

So now the question is why would coping and pasting named ranges into a Word doc cause this slowdown. Could it be to do with the clipboard being overloaded although I use a Application.CutCopyMode = False at the end, or is it to do with the tables inserted as links and somehow Excel thinks it needs to update them (even though they are all locked - not automatically updated - within the code) or is it something else?

Derek

RoryA · Feb 20, 2009

Could be the links, I suppose. Do you close the Word document(s) and app at the end?

derekpegg · Feb 20, 2009

I close the Word template leaving the completed mail merge doc open at the end. I'm trying to find a way to see if I can code into the macro to fully break the links (rather than just lock them) to see if that helps. I will also see if cloing the merged Word doc (which is usually left open) does anything.

Derek

derekpegg · Feb 20, 2009

Rory

Think we have a resolution to this.

I search around for something to break the links to the inserted named ranges in the Word doc (rather than just lock them).

I found the line of code:

aField.LinkFormat.BreakLink

Which I put in the following code:

For Each aField In appWd.ActiveDocument.Fields
aField.LinkFormat.BreakLink
Next aField

This successfully broke the links and although this is not absolutely ideal (ie. cannot update the linked tables if needed in future) it is more than acceptable for my purpose.

I find it odd that Word treats a locked and unlinked table differently - I would have though neither would have any link back to Excel unless prompted (in the case of the locked (by unlocking) tables), but little suprises me in the wonderfully strange world of MS Office anymore.

I would just like to say a big thanks to you (and Anthony) for you interest and comments and that I really appreciate this forum and I hope this thread helps out others in the same position in future.

Derek

Why does Excel run slowly / unresponsively AFTER this macro has completed successfully?

derekpegg

Board Regular

RoryA

MrExcel MVP, Moderator

Excel Facts

derekpegg

Board Regular

RoryA

MrExcel MVP, Moderator

derekpegg

Board Regular

derekpegg

Board Regular

Similar threads

Forum statistics

Share this page

Why does Excel run slowly / unresponsively AFTER this macro has completed successfully?

derekpegg

Board Regular

RoryA

MrExcel MVP, Moderator

Excel Facts

derekpegg

Board Regular

RoryA

MrExcel MVP, Moderator

derekpegg

Board Regular

derekpegg

Board Regular

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock