VBA Loop not sending data to word in a consistent way - vba

Question

I have the below code that goes through a simple spreadsheet for now and paste the organisation,
one table a single cell value and a chart into a word template. The code runs and produces both a word and pdf version correctly. But what I see is that the table is on occasion ended up where the organisation should be and the chart is being repeated in the document. Each output of the loop seems to vary and I can't work out if the information is not being cleared from the clipboard before it gets pasted. Do I need to run the sections into sub sections or something?
Appreciate the help.
Sub CreateBasicWordReport()
Dim WdApp As Word.Application
Dim wdDoc As Word.Document
Dim SaveName As String
Dim FileExt As String
Dim LstObj1 As ListObject
Dim MaxValue As Integer
Dim FilterValue As Integer
Dim Organisation As String
Dim Rng As Range
Dim WS As Worksheet
Set LstObj1 = Worksheets("Sheet1").ListObjects("Table1")
MaxValue = WorksheetFunction.Max(LstObj1.ListColumns(1).Range)
FilterValue = MaxValue
Set WdApp = CreateObject("Word.Application")
Do Until FilterValue = 0
Application.DisplayAlerts = False
Sheets.Add(After:=Sheets("Sheet1")).Name = "Static"
Sheets("Sheet1").Select
'moved outside of loop
' Set WdApp = CreateObject("Word.Application")
With WdApp
.Visible = True
.Activate
'create new document and assign to object variable
Set wdDoc = .Documents.Add("C:\Users\david\Documents\Custom Office Templates\Template2.dotx")
'now mostly finished with WdApp as from here wdDoc is used
End With
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:=FilterValue
Range("F11").Select
Range("A1", Range("A1").End(xlDown).End(xlToRight)).Copy
' .Selection.GoTo what:=-1, Name:="TableLocation"
' .Selection.Paste
wdDoc.Bookmarks("TableLocation").Range.Paste
For Each Row In Range("Table1[#All]").Rows
If Row.EntireRow.Hidden = False Then
If Rng Is Nothing Then Set Rng = Row
Set Rng = Union(Row, Rng)
End If
Next Row
Set WS = Sheets("Static")
Rng.Copy Destination:=WS.Range("A1")
' Sheets("Static").Select
' Sheets("Static").Activate
Organisation = WS.Range("D2").Value
' Sheets("Static").Select
' Range("D2").Copy
WS.Range("D2").Copy
' .Selection.GoTo what:=-1, Name:="Organisation"
' .Selection.PasteAndFormat wdFormatPlainText
wdDoc.Bookmarks("Organisation").Range.PasteAndFormat wdFormatPlainText
Application.CutCopyMode = False
' Sheets("Static").Select
' Range("F2").Copy
WS.Range("F2").Copy
' .Selection.GoTo what:=-1, Name:="MalePatients"
' .Selection.PasteAndFormat wdFormatPlainText
wdDoc.Bookmarks("MalePatients").Range.PasteAndFormat wdFormatPlainText
Application.CutCopyMode = False
Chart2.ChartArea.Copy
' .Selection.GoTo what:=-1, Name:="ChartLocation"
' .Selection.Paste
wdDoc.Bookmarks("ChartLocation").Range.Paste
If WdApp.Version <= 11 Then
FileExt = ".doc"
Else
FileExt = ".docx"
End If
SaveName = Environ("UserProfile") & "\Desktop\Report for " & _
Organisation & " " & _
Format(Now, "yyyy-mm-dd hh-mm-ss") & FileExt
If WdApp.Version <= 12 Then
' .ActiveDocument.SaveAs SaveName
wdDoc.SaveAs SaveName
Else
' .ActiveDocument.SaveAs2 SaveName
wdDoc.SaveAs2 SaveName
End If
SaveNamePDF = Environ("UserProfile") & "\Desktop\Report " & _
Organisation & " " & _
Format(Now, "yyyy-mm-dd hh-mm-ss") & ".pdf"
wdDoc.ExportAsFixedFormat _
OutputFileName:=SaveNamePDF, _
ExportFormat:=wdExportFormatPDF _
wdDoc.Close
FilterValue = FilterValue - 1
Sheets("Static").Delete
Application.DisplayAlerts = True
Loop
WdApp.Quit
Set WdApp = Nothing
End Sub

Answer 1

You may or may not want to take this as an answer to your question, but here are some ways you can improve your code so as to gain better control over how it operates. It is not a "solution" in the sense of a completed, correctly working code module, but if you adopt this advice it should enable you to solve the issue yourself (along with many other issues you might otherwise encounter in the future).
(1) Avoid using Copy and Paste. As you correctly note, those put you at the mercy of the Windows clipboard. Instead, assign the source object or value to a variable, then insert the contents of the variable at the destination. For instance:
Organisation = WS.Range("D2").Value
wdDoc.Bookmarks("Organisation").Range.Text = Organisation
Now you are able to control what is inserted at the destination point. Among other things, you can reset the variable at the end of each loop, so that there is no risk of repeatedly inserting an object or value that may be carried over from one loop cycle to the next.
(2) Use With ... End With to explicitly specify the parents of your objects. That way you don't risk accidentally referencing a different object than you expected. For instance, in this excerpt from your code ...
With WdApp
Set wdDoc = .Documents.Add("C:\Users\david\Documents\Custom Office Templates\Template2.dotx")
End With
Range("A1", Range("A1").End(xlDown).End(xlToRight)).Copy
... the range copied in the last line may not be what you expect. If the active object at the moment is your newly minted Word doc, the Range object may be interpreted as some range in the document, rather than the spreadsheet range you wanted to copy.
To stay in control, use With consistently:
With WdApp
Set wdDoc = .Documents.Add("C:\Users\david\Documents\Custom Office Templates\Template2.dotx")
End With
With MyWorkbook.Sheets("MySheet")
Set MyTableRange = .Range("A1", .Range("A1").End(xlDown).End(xlToRight))
End With
That's just a couple of pointers, but these are basic good coding practices that you should adopt. I think they will help you resolve the issues with your code.

Answer 2

The issues you are seeing are likely being caused by using the clipboard. There can be a delay when copying and pasting larger items, e.g. tables of data, charts.
When you use the clipboard you are passing some control over to the OS. VBA includes a function, DoEvents that passes control to the operating system. Control is then returned after the operating system has finished processing the events in its queue. By adding this after each copy/paste it should allow things to catch up.
You can also slightly reduce your use of the clipboard by setting the values for 'Organisation' and 'Male Patients' directly.
Sub CreateBasicWordReport()
Dim WdApp As Word.Application
Dim wdDoc As Word.Document
Dim SaveName As String
Dim FileExt As String
Dim LstObj1 As ListObject
Dim MaxValue As Integer
Dim FilterValue As Integer
Dim Organisation As String
Dim Rng As Range
Dim WS As Worksheet
Application.DisplayAlerts = False
Set LstObj1 = Worksheets("Sheet1").ListObjects("Table1")
MaxValue = WorksheetFunction.Max(LstObj1.ListColumns(1).Range)
FilterValue = MaxValue
Set WdApp = CreateObject("Word.Application")
Do Until FilterValue = 0
Sheets.Add(After:=Sheets("Sheet1")).Name = "Static"
Sheets("Sheet1").Select
With WdApp
.Visible = True
.Activate
'create new document and assign to object variable
Set wdDoc = .Documents.Add("C:\Users\david\Documents\Custom Office Templates\IBD Registry Quarterly Report Template2.dotx")
'now mostly finished with WdApp as from here wdDoc is used
End With
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:=FilterValue
Range("F11").Select
Range("A1", Range("A1").End(xlDown).End(xlToRight)).Copy
wdDoc.Bookmarks("TableLocation").Range.Paste
DoEvents
For Each Row In Range("Table1[#All]").Rows
If Row.EntireRow.Hidden = False Then
If Rng Is Nothing Then Set Rng = Row
Set Rng = Union(Row, Rng)
End If
Next Row
Set WS = Sheets("Static")
Rng.Copy Destination:=WS.Range("A1")
Application.CutCopyMode = False
DoEvents
Organisation = WS.Range("D2").Value
wdDoc.Bookmarks("Organisation").Range.Text = Organisation
wdDoc.Bookmarks("MalePatients").Range.Text = WS.Range("F2").Text
Chart2.ChartArea.Copy
wdDoc.Bookmarks("ChartLocation").Range.Paste
DoEvents
Application.CutCopyMode = False
If CLng(WdApp.Version) <= 11 Then
FileExt = ".doc"
Else
FileExt = ".docx"
End If
SaveName = Environ("UserProfile") & "\Desktop\IBD Registry Quarterly Report for " & _
Organisation & " " & _
Format(Now, "yyyy-mm-dd hh-mm-ss")
SaveNamePDF = SaveName & ".pdf"
SaveName = SaveName & FileExt
If CLng(WdApp.Version) <= 12 Then
wdDoc.SaveAs SaveName
Else
wdDoc.SaveAs2 SaveName
End If
wdDoc.ExportAsFixedFormat _
OutputFileName:=SaveNamePDF, _
ExportFormat:=wdExportFormatPDF _
wdDoc.Close
FilterValue = FilterValue - 1
Sheets("Static").Delete
Application.DisplayAlerts = True
Loop
WdApp.Quit
Set WdApp = Nothing
End Sub