Copy and excel Worksheet content to a table in new Word doc (header issues)

[GeorgeBrown]

Hi - bit of a long one, apologies I did also post this issue here: before being aware of the rules (joined today). Copy excel Worksheet content to a table in new Word do (header issues)


I have a summary page of an excel toolkit, with a button that then copies this summary to MS Word doc. . There is content/paragraph from some cells and then a table in the word doc from the rest of the worksheets content. I wanted the table's rows to not carry over to the next word pages and to have the table headings at the top of each new page, this is to keep it neat with the row's content on one page. This all works fine.

My problem is is that making sure the table headings appear at the start of each new page when the table is, the table headings now appear at the top of EVERY page, rather than just where the table is. What I would like (if possible) is the table headings to only appear on the pages where the table exists, and not on the first few pages where it doesn't (it doesn't look right that there the table headings above the first paragraph). I hope that makes sense.

In a perfect world I need the following:
1) cell B1 to go in the word doc's header
2) copy to word cell range B3:G4 WITHOUT table header starting at new page (this is the first paragraph)
3) copy to word cell range B8:G25 WITHOUT table header starting at new page (2nd paragraph)
3) copy cell range B27:G45 (the content that goes into table) WITH table header starting at every new page with the table. The table header's reference is B2.

I hope that's clear and makes sense, its a tricky one (for me anyway!) and any help would be much appreciated. I'm sure its something simple but I'm struggling. Many thanks.

Code (both modules) below:

MODULE 1:

Sub CopyWorksheetsToWord()
Dim wdApp As Object, wdDoc As Object, ws As Worksheet
Const wdOrientLandscape = 1
Application.ScreenUpdating = False
Application.StatusBar = "Creating new document..."
Set wdApp = CreateObject("Word.Application")
Set wdDoc = wdApp.Documents.Add
Set ws = Sheets("4. SUMMARY")
Application.StatusBar = "Copying data from " & ws.Name & "..."
With wdDoc
Range("B1:G4").Copy
.Range.Characters.last.Paste
Range("B8:G45").Copy
.Range.Characters.last.Paste
.Tables(1).Rows(2).headingFormat = True
End With
With wdDoc.PageSetup
.Orientation = wdOrientLandscape
.LeftMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(0.7)
.BottomMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
End With
Set ws = Nothing
Application.StatusBar = "Cleaning up..."
With wdApp.ActiveWindow
If .View.SplitSpecial = wdPaneNone Then
Else
.View.Type = wdNormalView
End If
End With
Set wdDoc = Nothing
wdApp.Visible = True
Set wdApp = Nothing
Application.StatusBar = False
End Sub

MODULE 2:
Sub CopyRangetoWord_Multi()
'Declare Word Variables
Dim wdApp As Object, wdDoc As Object, ws As Worksheet
Const wdOrientLandscape = 1
Application.ScreenUpdating = False
'Declare Excel Variables
Dim Rng As Variant
'Dim ExcRng As Range
Dim RngArray As Variant

'Create a new Word
Set wdApp = CreateObject("Word.Application")
Set wdDoc = wdApp.Documents.Add

Set ws = Sheets("4. SUMMARY")
wdApp.Visible = True
wdApp.Activate

'Populate my range array
RngArray = Array(ws.Range("B27:G45"))

'Loop through each element
For Each Rng In RngArray

'Create a reference to the range I want to Copy
'Set ExcRng = Rng
Rng.Copy

'Pause the Excel application for 1 seconds
Application.Wait Now() + #12:00:01 AM#

'With the current selection paste the range
With wdApp.Selection
.PasteSpecial DataType:=wdPasteOLEObject, Link:=True
End With

'Create a new page
wdApp.ActiveDocument.Sections.Add

'Go to newly created page
wdApp.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext
Next
With wdDoc.PageSetup
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.InsertParagraphAfter
wdDoc.Paragraphs(wdDoc.Paragraphs.Count).Range.Paste
Application.CutCopyMode = False
wdDoc.PageSetup.Orientation = wdOrientLandscape
wdDoc.PageSetup.LeftMargin = Application.InchesToPoints(0.7)
wdDoc.PageSetup.TopMargin = Application.InchesToPoints(0.7)
wdDoc.PageSetup.BottomMargin = Application.InchesToPoints(0.5)
wdDoc.Tables(1).Rows(2).headingFormat = True
End With
Set ws = Nothing
Application.StatusBar = "Cleaning up..."

Set wdDoc = Nothing
wdApp.Visible = True

Set wdApp = Nothing
Application.StatusBar = False

'Clear my clipboard
Application.CutCopyMode = False

End Sub