|
I am using Access VBA 2013 to automate the creation of a report in Word based on a templated page which uses Tables & Nested Tables to hold data.
The table structure is as follows Main Table with 3 Rows. The First & Lat Row hold nested tables which are used as headers and footer information that holds field names and totals.
The Middle row has a nested table which holds the detail of the record details. The data is grouped and the table is copy and pasted to create group sections for each grouped record set.
I am using the PasteAsNestedTable to add a new group section.
The code below works fine if the word doc is visible when the code is running, however when i make the doc invisible (Visible = False) the columkn width settings of the nested table in First Row of the main table is altered.
I have moved the
With wApp
.Visible = Truecommand through the code and it all works fine until you get to the
rs1.MoveNext
oRange2.Collapse wdCollapseEnd
oRange2.PasteAsNestedTableAnd then the formating of the columns is affected?
Here is the code that I am using: Any help would be graetly appreciated.
Private Sub btnCreateChart6_Click()
On Error GoTo btnCreateChart6_Err
'
'************
'DECLARATIONS
'************
Dim rngTemp As Range
Dim i As Integer
Dim y As Integer
Dim Msg As String
Dim wApp As Word.Application
Dim tb As Table
Dim tb2 As Table
Dim strWordMasterDoc As String
Dim strWordOutputDoc As String
Dim strWordTestDoc As String
Dim intRowOffset As Integer
Dim db As Database
Dim rs1 As DAO.Recordset 'Group records
Dim rs2 As DAO.Recordset 'Item records
Dim rs2Filtered As DAO.Recordset 'Filtered item records
'
'*************
'SET VARIABLES
'*************
strWordMasterDoc = "J:\Template.docx"
strWordOutputDoc = "J:\Ouput.docx"
Set db = CurrentDb()
Set rs1 = db.OpenRecordset("GroupThemeSum", dbOpenSnapshot)
Set rs2 = db.OpenRecordset("GroupTheme", dbOpenSnapshot)
rs1.MoveFirst
If rs1.BOF Then
Err.Raise 32000
End If
'
'**********************************
'CHECK DOCUMENTS NOT ALREADY IN USE
'**********************************
strWordTestDoc = strWordMasterDoc
Open strWordMasterDoc For Binary Access Read Lock Read As #1 'creates error 70 if already open
Close #1
strWordTestDoc = strWordOutputDoc
Open strWordOutputDoc For Binary Access Read Lock Read As #1 'creates error 70 if already open
Close #1
'
'************************
'OPEN WORD AND FILL TABLE
'************************
Set wApp = CreateObject("Word.application")
wApp.Documents.Open strWordMasterDoc
With wApp
.Visible = True
ValuationDate wApp
Set tb = .ActiveDocument.Tables(1).Cell(2, 1).Tables(1)
tb.AllowAutoFit = False
intRowOffset = 0
Do Until rs1.EOF
'tb.Rows.Add
intRowOffset = intRowOffset + 1
'.ActiveDocument.Range(tb.Cell(intRowOffset, 1).Range.start, tb.Cell(intRowOffset, 2).Range.End).Cells.Merge
clte tb, intRowOffset, 1, rs1!LvoName10
clte tb, intRowOffset, 3, Format(rs1!Cost, "£#,##0.00")
clte tb, intRowOffset, 4, Format(rs1!CurrentValue, "£#,##0.00")
clte tb, intRowOffset, 5, Format(rs1!IncomeRec, "£#,##0.00")
clte tb, intRowOffset, 6, Format(rs1!NominalReturn, "£#,##0.00")
clte tb, intRowOffset, 7, Format(rs1!NominalReturnPerc, "0.00%")
clte tb, intRowOffset, 8, Format(rs1!IncomeEst, "£#,##0.00")
clte tb, intRowOffset, 9, Format(rs1!YieldEst, "0.00%")
clte tb, intRowOffset, 10, Format(rs1!Exposure, "0.00%")
rs2.Filter = "LvoCode10 = " & rs1!LvoCode10
Set rs2Filtered = rs2.OpenRecordset
rs2Filtered.MoveFirst
Do Until rs2Filtered.EOF
'tb.Rows.Add
intRowOffset = intRowOffset + 1
clte tb, intRowOffset, 2, rs2Filtered!SecurityName
clte tb, intRowOffset, 3, Format(rs2Filtered!Quantity, "#,##0.00")
clte tb, intRowOffset, 4, Format(rs2Filtered!IndexedBookCost, "£#,##0.00")
clte tb, intRowOffset, 5, Format(rs2Filtered!CurrentValue, "£#,##0.00")
clte tb, intRowOffset, 6, Format(rs2Filtered!IncomeRec, "£#,##0.00")
clte tb, intRowOffset, 7, Format(rs2Filtered!NominalReturn, "£#,##0.00")
clte tb, intRowOffset, 8, Format(rs2Filtered!NominalReturnPerc, "0.00%")
clte tb, intRowOffset, 9, Format(rs2Filtered!IncomeEst, "£#,##0.00")
clte tb, intRowOffset, 10, Format(rs2Filtered!YieldEst, "0.00%")
clte tb, intRowOffset, 11, Format(rs2Filtered!Exposure, "0.00%")
rs2Filtered.MoveNext
If Not rs2Filtered.EOF Then
tb.Rows.Add
End If
Loop
'.ActiveDocument.Bookmarks("PortfolioName").Range.Text = rs1!PortfolioName
If Not rs1.EOF Then
'code to copy and paste top two lines
Dim oRange2 As Range
Dim oRange3 As Range
Set oRange2 = tb.Range
Set oRange3 = .ActiveDocument.Range(tb.Rows(1).Range.start, _
tb.Rows(2).Range.End)
oRange3.Copy
rs1.MoveNext
oRange2.Collapse wdCollapseEnd
oRange2.PasteAsNestedTable
End If
Loop
.ActiveDocument.SaveAs2 strWordOutputDoc
.ActiveDocument.Close False
.Quit
End With
MsgBox "Processing Complete"
'
'************
'HOUSEKEEPING
'************
Housekeeping:
Set wApp = Nothing
Set rs1 = Nothing
Set db = Nothing
Exit Sub
'
'**************
'ERROR HANDLING
'**************
btnCreateChart6_Err:
Msg = ""
Select Case Err.Number
Case 70
Msg = "The document " & strWordTestDoc & " is already open. Close this instance of the master document and try again."
Case 32000 'no records in rs1
GoTo Housekeeping
Case Else
On Error GoTo 0
Resume
End Select
If Msg <> "" Then
MsgBox Msg, vbOKOnly + vbInformation, "btnCreateChart2_Err"
End If
GoTo Housekeeping
End Sub
|
