Transferring table and cell data from Excel to Word using VBA

[crvazquez954]

Hello everyone, my boss has me working on a spreadsheet that pulls information from various tabs into 1 "Summary" tab. We then VBA code to put the information into a table (removing any blank rows in the process) and transfer to a word template called "Proposal" located in the same folder as the workbook. What I am trying to figure out is how to also transfer data in various other cells to bookmarks on the Proposal document. Can anyone help me tweak the VBA code below to include this information?

Sub Export_Table_Word() 'FINAl TEST
'Name of the existing Word doc.
Const stWordReport As String = "Proposal.docm"


'Word objects.
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wdbmRange As Word.Range


'Excel objects.
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim rnReport As Range
Dim r As Range


'Initialize the Excel objects.
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Summary")
Set rnReport = wsSheet.Range("BidTable")


'Remove formatting
Range("B28:D47").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With


For Each r In rnReport.Rows
If WorksheetFunction.Count(r) = 0 Then r.Hidden = True
Next


'Initialize the Word objects.
Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Open(wbBook.Path & "" & stWordReport)
Set wdbmRange = wdDoc.Bookmarks("BidTable").Range
wdApp.Visible = True
'If the macro has been run before, clean up any artifacts before trying to paste the table in again.
On Error Resume Next
With wdDoc.InlineShapes(1)
.Select
.Delete
End With
On Error GoTo 0


'Turn off screen updating.
Application.ScreenUpdating = False
rnReport.Copy 'Copy the report to the clipboard.


'Select the range defined by the "Report" bookmark and paste in the report from clipboard.
With wdbmRange
.Select
.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
Placement:=wdInLine, DisplayAsIcon:=False
End With


'Unhide hidden rows
Rows("26:48").Select
Selection.EntireRow.Hidden = False


'Restore formatting
Range("B28:D47").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With


Application.ScreenUpdating = True
MsgBox "The report has successfully been " & vbNewLine & "transferred to " & stWordReport, vbInformation
End Sub

 

[crvazquez954]

I've tried combining this code with another that will successfully transfer cell data to word bookmarks but for some reason the excel table range ("BidTable") causes a problem. Any ideas on how to get this to work?