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

[derekpegg]

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.

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

 

[derekpegg]

I'm running Excel 2000 (SP3) on Office XP (SP3) if this is relevant or helpful.

 

[Anthony47]

Could you start the task manager (Contr-Alt-Del) and check which is the cpu occupancy before and after the macro (tab Performaces), and which processes eat cpu time (tab Processes, sorted by CPU).

Maybe this will give some evidence on the area of problem.

Bye.

 

[derekpegg]

Hi Anthony - thanks for the quick reply.

OK - hopefully this is the info that might be of use:



Before Macro Run:

CPU usage about 0%-2%

Excel.exe using 72,588K


After Macro Run (when I select any other cell/sheet on the workbook):

CPU usage about 50-60% for several minutes

Excel.exe using 80,632K



Thanks

Derek

 

[Anthony47]

You wrote that the cpu usage remains high for "sevaral minutes": does this happen while the macro is in execution or it lasts after the end of the macro?
When the cpu usage returns to 0-2% (quite low), does your sheet run fast or slow?
During those "several minutes", which are the processes most demanding (tab Processes, sort by cpu)? Which is the total allocated memory (tab Performances, in MBytes) when it runs fast, during macro execution, during those several minutes and after?
The more you details, the higher the chances we will get a good idea..

Bye.

 

[derekpegg]

OK Anthony

For your info - my specs are: 2.4ghz dual core with 1gb RAM but I have run this on dozens of computers of different specs and different OS and Office versions and it is the same on all.

I have just tested it again with the following results (hopefully some more useful info):

When the workbook is loaded, but before this macro is run, the only process using major resource is Excel at about 73,300K and CPU usage is about 0-2%. The workbooks works about a speedily as any other - fairly fast.

During running on this macro, Excel mem usage seems to drop to around 21,000K and CPU use swings from 15% to 60%, an at one point got up to 80%, before returning to around 15% near the end of the code.

After the macro is finished, Excel mem usage is around 32,000K and CPU usage back to 0-2% as before it ran. On the 'applications' tab, Excel is 'running'.

Now if I try and do anything else on the workbook, Excel goes extremely slow or it is unresponsive. Ie. if I select another worksheet which has an on worksheet_activate macro which usually takes < 1 sec (before running the macro in question), it probably takes about 1 min approx to complete. During this time, Excel jumps to 53,000 approx mem usage and 50-60% CPU usage. Also, during this, Excel changes to 'not responding' in the task manager. Similarly, even selecting a cell (not event triggered) takes around 10-15 secs while it 'hangs'.

Having left the workbook open for a long time after running this macro today, it seems to stay in this state for around 7-8 mins on my computer but somewhat longer on lower specced machines. Once it is back to 'normal' speed, the CPU and mem stats return to around the same levels as they started (eg. about 73,300K and CPU usage is about 0-2%).

Hope this is enough info, but if anything else would be of use, please let me know.

Thanks again for your interest and help on this.

Derek

 

[RoryA]

Are there any messages in the status bar? It may be that Excel is recalculating slowly.

 

[derekpegg]

Thanks for your interest Rory.

I normally have the status bar hidden, but if I unhide it and re run the macro, after it has run (when the workbook is very slow / unresponsive), the status bar does not say 'calculating', it is either blank or 'ready'. It even shows 'ready' when it is being extremely slow. If I tab accross a worksheet from one cell to the next, it says 'ready' but each cell takes a good 30 secs to be selected as it crawls through (no code activated - just selecting the next cell). Any ideas?

Derek

 

[RoryA]

It appears, from a quick skim through the code, you are doing a mailmerge using the workbook you are running the code from - is that correct?

 

[derekpegg]

Yep - that's right. The code opens a Word template, pastes named ranges in then runs a mail merge from data in the workbook into the Word template creating a merged Word document (via ODBC rather than DDE) then closes the Word template leaving the merged Word doc open.

Derek