How to generate the word report from excel? - vba

I want to convert the following excel content into a word document .
The new word report contains the student name ,date ,subject , original exam time and new exam time .
I tried to use a simple way to do this . Copy range(a79:L85) & range(A90:L92) to the new word document .But it doesn't work and joins the two table together (into same row ).
Sub ExcelRangeToWord()
'PURPOSE: Copy/Paste An Excel Table Into a New Word Document
'NOTE: Must have Word Object Library Active in Order to Run _
(VBE > Tools > References > Microsoft Word 12.0 Object Library)
'SOURCE: www.TheSpreadsheetGuru.com
Dim tbl As Excel.RANGE
Dim tbl2 As Excel.RANGE
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Copy Range from Excel
Set tbl = ThisWorkbook.Worksheets(sheet9.Name).RANGE("A79:L85") 'copy the name ,subject and old exam time
Set tbl2 = ThisWorkbook.Worksheets(sheet99.Name).RANGE("A90:L92")'copy the new exam time
'Create an Instance of MS Word
On Error Resume Next
'Is MS Word already opened?
Set WordApp = GetObject(Class:="Word.Application")
'Clear the error between errors
Err.Clear
'If MS Word is not already open then open MS Word
If WordApp Is Nothing Then Set WordApp = CreateObject(Class:="Word.Application")
'Handle if the Word Application is not found
If Err.Number = 429 Then
MsgBox "Microsoft Word could not be found, aborting."
GoTo EndRoutine
End If
On Error GoTo 0
'Make MS Word Visible and Active
WordApp.Visible = True
WordApp.Activate
'Create a New Document
Set myDoc = WordApp.Documents.Add
'Copy Excel Table Range
tbl.Copy ' paste range1
tbl2.Copy 'paste range2
'Paste Table into MS Word
myDoc.Paragraphs(1).RANGE.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
'Autofit Table so it fits inside Word Document
Set WordTable = myDoc.Tables(1)
WordTable.AutoFitBehavior (wdAutoFitWindow)
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
Any hints or methods can generate a word report like this ?

This could be only a part of the solution explaining of how to copy+paste tables one after another.
'....
'Trigger copy separately for each table + paste for each table
tbl.Copy ' paste range1
myDoc.Paragraphs(1).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
'before that...
'...go to end of doc and add new paragraph
myDoc.Bookmarks("\EndOfDoc").Range.InsertParagraphAfter
tbl2.Copy 'paste range2
'Paste Table into MS Word last paragraph
myDoc.Paragraphs(myDoc.Paragraphs.Count).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False

Related

Copy Word table to Excel and format as table

I have a macro in Word VBA that copies a table from a Word file and pastes it to Excel.
It pastes it like this:
My question now, is it possible to format that table as an “Excel table”, like when you insert a table in excel, using the vba in word?
To get the final result as this:
I mean I know how to do it using a macro in the same excel file but how can I format it from the word vba?
My problem is that I need to do it from word vba as I don’t have the option of doing it in an excel vba.
Thank you everyone!
My code is:
Dim wrdTbl As Table, c As Long
'Excel Objects
Dim oXLApp As Object, oXLwb As Object, oXLws As Object
'Set your table
With ActiveDocument
If ActiveDocument.Tables.Count >= 1 Then
Set wrdTbl = .Tables(InputBox("Table # to copy? There are " & .Tables.Count & " tables to choose from."))
End If
End With
'Create a new Excel Application
Set oXLApp = CreateObject("Excel.Application")
With oXLApp
'Hide Excel
.Visible = False
'Open the relevant Excel file
Set oXLwb = oXLApp.Workbooks.Open("C:\Users\" & Environ("Username") & "\Desktop\ExcelEx.xlsx")
End With
wrdTbl.Range.Copy
With oXLwb.Sheets(1)
.Paste .Range("A1")
End With
'Close and save Excel file
oXLwb.Close True
'Cleanup (VERY IMPORTANT)
oXLApp.Quit
Set oXLwb = Nothing: Set oXLApp = Nothing
MsgBox "Done"
End Sub
Something like that
With oXLwb.Sheets(1)
.Paste .Range("A1")
Dim LastRow As Long
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Dim LastCol As Long
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
.ListObjects.Add(SourceType:=xlSrcRange, Source:=.Range("A1", .Cells(LastRow, LastCol)), XlListObjectHasHeaders:=xlYes).TableStyle = "TableStyleMedium2"
End With
should format it as table. Adjust to your needs and desired style.
Here is a good resource on how to Find last row, column or last cell.

Paste from current sheet to end of book into Word docs as picture

I currently have a working macro (modified code from TheSpreadsheetGuru) that copies from A1 to last used row in column H and pastes that data as a picture to a Microsoft Word document. It works great, but I have to run the macro more than 20 times (once for each sheet), and I have multiple reports I run each week with this same criteria. Is it possible to have this code iterate through all the worksheets from the active sheet (which would be the first sheet needed) through the end of the workbook? I could use the worksheet names (Linda is first, Victoria is last sheet) but the names change fairly often and more sheets are often added, and I don't want to have to change the code each time.
Sub PasteAsPicture()
Dim tbl As Excel.Range
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim lastrow As Long
Dim startcell As Range
Set startcell = Range("H4")
PicNme = ActiveSheet.name & ".docx"
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Copy Range from Excel
With ActiveSheet
lastrow = ActiveSheet.Cells(.Rows.Count, startcell.Row).End(xlUp).Row
Set tbl = ActiveSheet.Range("A1:H" & lastrow)
End With
'Create an Instance of MS Word
On Error Resume Next
'Is MS Word already opened?
Set WordApp = GetObject(class:="Word.Application")
'Clear the error between errors
Err.Clear
'If MS Word is not already open then open MS Word
If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application")
'Handle if the Word Application is not found
If Err.Number = 429 Then
MsgBox "Microsoft Word could not be found, aborting."
GoTo EndRoutine
End If
On Error GoTo 0
'Make MS Word Visible and Active
'WordApp.Visible = True
'WordApp.Activate
'Create a New Document
Set myDoc = WordApp.documents.Add
'Copy Excel Table Range
tbl.CopyPicture xlPrinter
'Paste Table into MS Word
With myDoc.PageSetup
.Orientation = wdOrientLandscape
.TopMargin = WordApp.InchesToPoints(1)
.BottomMargin = WordApp.InchesToPoints(1)
.LeftMargin = WordApp.InchesToPoints(0.5)
.RightMargin = WordApp.InchesToPoints(0.5)
End With
With myDoc
.Paragraphs(1).Range.Paste
.SaveAs Filename:="H:\QBIRT Reports\New Establishments\Reports\" & PicNme
.Close
End With
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
VBA uses the For Each... Next Statement to loop over arrays and collections. Using this method you can repeat the same action on every worksheet in the workbook.
' Calls PasteAsPicture, for each sheet in the workbook.
Sub ForEachWorksheet()
Dim ws As Worksheet
' Loop over every sheet in the book.
For Each ws In ThisWorkbook.Sheets
' Paste as picture requires the current sheet to be selected.
' You cannot activate hidden and very hidden sheets, without first unhiding.
If ws.Visible = xlSheetVisible Then
ws.Activate
PasteAsPicture
End If
Next
End Sub
If you want to start building up a library of VBA macros, that you can call from any workbook, research Excel's start up path and .xla file format.

Subscript out of range error - vba

I am trying to copy and paste multiple tables from excel to word but it's giving me Subscript out of range error when I am trying to define tbl. I found the codes online and is trying to modify the codes to suit my needs.
Sub ExcelTablesToWord_Modified()
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim sheet As Excel.Worksheet
Dim tableName As String
With dict
.Add "TableA1", "TableA1"
.Add "TableA2", "TableA2"
.Add "TableB1", "TableB1"
.Add "TableB2", "TableB2"
.Add "TableC", "TableC"
.Add "TableD", "TableD"
.Add "TableE1", "TableE1"
.Add "TableE2", "TableE2"
.Add "TableF1", "TableF1"
.Add "TableF2", "TableF2"
'TODO: add the remaining WorksheetName/TableName combinations
End With
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Set Variable Equal To Destination Word Document
On Error GoTo WordDocNotFound
Set WordApp = GetObject(class:="Word.Application")
WordApp.Visible = True
Set myDoc = WordApp.Documents("a.docx")
On Error GoTo 0
'Loop Through Worksheets, and Copy/Paste Multiple Excel Tables
For Each sheet In ActiveWorkbook.Worksheets
tableName = dict(sheet.Name)
'Copy Table Range from Excel
sheet.ListObjects(tableName).Range.Copy
'Paste Table into MS Word (using inserted Bookmarks -> ctrl+shift+F5)
myDoc.Bookmarks(tableName).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
'Autofit the most-recently-pasted Table so it fits inside Word Document
myDoc.Tables(myDoc.Tables.Count).AutoFitBehavior (wdAutoFitWindow)
Next sheet
'Completion Message
MsgBox "Copy/Pasting Complete!", vbInformation
GoTo EndRoutine
'ERROR HANDLER
WordDocNotFound:
MsgBox "Microsoft Word file 'b' is not currently open, aborting.", 16
'Put Stuff Back The Way It Was Found
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
Below will copy the first Table in every worksheet and paste into Word doc, regardless of the Table Name. The bookmark names in the Word doc assumed to be simply start at 1 with prefix "bookmark".
If specific Table names are really required, then create a Collection for the names, and loop through each Table in each Worksheet, if that table name is in the Collection then proceed to copy.
Option Base 1 'Force arrays to start at 1 instead of 0
Sub ExcelTablesToWord()
Dim oWS As Worksheet
Dim tbl As Excel.Range
Dim WordApp As Object ' Word.Application
Dim myDoc As Object ' Word.Document
Dim x As Long ' Integer
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Set Variable Equal To Destination Word Document
On Error Resume Next
Set WordApp = GetObject(, "Word.Application")
If WordApp Is Nothing Then Set WordApp = CreateObject("Word.Application")
If WordApp Is Nothing Then GoTo WordDocNotFound
WordApp.Visible = True
Set myDoc = WordApp.Documents("a.docx")
If myDoc Is Nothing Then Set myDoc = WordApp.Documents.Open("a.docx")
If myDoc Is Nothing Then GoTo WordDocNotFound
'Loop Through and Copy/Paste Multiple Excel Tables
x = 1 ' For x = LBound(TableArray) To UBound(TableArray)
For Each oWS In ThisWorkbook.Worksheets
'Copy Table Range from Excel
'Set tbl = ThisWorkbook.Worksheets(x).ListObjects(TableArray(x)).Range
Set tbl = oWS.ListObjects(1).Range
If Not tbl Is Nothing Then
tbl.Copy
'Paste Table into MS Word (using inserted Bookmarks -> ctrl+shift+F5)
myDoc.Bookmarks("bookmark" & x).Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
'Autofit Table so it fits inside Word Document
myDoc.Tables(x).AutoFitBehavior 2 ' (wdAutoFitWindow)
x = x + 1
End If
Next
On Error GoTo 0
'Completion Message
MsgBox "Copy/Pasting Complete!", vbInformation
GoTo EndRoutine
'ERROR HANDLER
WordDocNotFound:
MsgBox "Microsoft Word file 'b' is not currently open, aborting.", 16
'Put Stuff Back The Way It Was Found
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
The code I had originally provided was based on your original model, in which the corresponding Worksheet, Table, and Bookmark in each set had a different name.
Now that you have ensured that the names of the objects in each set are identical (which is a better model), try the following procedure. The only difference is that the Scripting.Dictionary has been eliminated, and the Worksheet name is being used to provide both the name of the Table and the name of the Bookmark (since all three values match now).
As before, this one has also been tested in Excel/Word 2016, and is functioning as expected:
Public Sub ExcelTablesToWord_Modified2()
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim sheet As Excel.Worksheet
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Set Variable Equal To Destination Word Document
On Error GoTo WordDocNotFound
Set WordApp = GetObject(class:="Word.Application")
WordApp.Visible = True
Set myDoc = WordApp.Documents("a.docx")
On Error GoTo 0
'Loop Through Worksheets, and Copy/Paste Multiple Excel Tables
For Each sheet In ActiveWorkbook.Worksheets
'Copy Table Range from Excel
sheet.ListObjects(sheet.Name).Range.Copy
'Paste Table into MS Word (using inserted Bookmarks -> ctrl+shift+F5)
myDoc.Bookmarks(sheet.Name).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
'Autofit the most-recently-pasted Table so it fits inside Word Document
myDoc.Tables(myDoc.Tables.Count).AutoFitBehavior (wdAutoFitWindow)
Next sheet
'Completion Message
MsgBox "Copy/Pasting Complete!", vbInformation
GoTo EndRoutine
'ERROR HANDLER
WordDocNotFound:
MsgBox "Microsoft Word file 'b' is not currently open, aborting.", 16
'Put Stuff Back The Way It Was Found
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
If you still receive the same error, then perhaps the Workbook is corrupted. In that case, try doing the following:
Create a new Workbook with one Worksheet
Rename the Worksheet so that its name matches the name of one of the Bookmarks in the Word document
Manually add a single, small, "testing-only" Table to the Worksheet (do not copy/paste one from the original Workbook)
Ensure that the Table's name is the same as the Worksheet's name
Copy/paste the above procedure into a new Module in that Workbook
Save the new Workbook
Ensure your Word document is open, and run the procedure
If that works, then you might consider recreating your entire original Workbook in the new Workbook. When doing so, if your datasets are large enough that you must copy/paste from the Original Workbook, use "Paste Special" with "Values Only" instead of just a normal Paste. Then, re-create any missing formatting manually. That way, it will be less likely that any corruption in the original Workbook will be transferred to the new one.

Dynamically select last row of a worksheet and enter selected data into an existing table in a word doc

Hi I’m a nube to excel VBA and would appreciate it greatly if someone could assist me in this issue.
I’ve spent over 5 days researching and reading, trying to solve this issue and can’t get the required result can anyone please help.
I’m using a userform to submit data to a worksheet then the above vba to open a word template, dynamically select the last line of the worksheet and enter selected cell data into a pre-existing table at various placeholder bookmarks within a word template.
The code always pastes the data above the table and not in it.
Here's the code i'm using
Sub testdata()
'declare variables
Dim wdDoc As Word.Document
Dim wdApp As Word.Application
'declare variable for save format
Dim savename As String
'declare fileext type for differnt versions of word
Dim fileext As String
'start word
Set wdApp = New Word.Application
'make it visible and activate it
With wdApp
'uncomment 2 lines below to see word on screen
.Visible = True
.Activate
'opens a word doc
.Documents.Add "C:\xxx\xxx\excel_project\test.docx"
'collect data range ref number
Range("A1").End(xlDown).Copy
'selects the item bookmark in word template
.Selection.GoTo What:=-1, Name:="Item"
'paste into word doc
.Selection.Paste
'test version type of word
If .Version <= 11 Then
fileext = ".doc"
Else
fileext = ".docx"
End If
'saves doc with specific timedate name
savename = "C:\xxx\xxx\excel_project\test" & _
Format(Now, "dd-mm-yyyy hh-mm-ss") & fileext
'changes save as method depended on word version
If .Version <= 12 Then
.ActiveDocument.SaveAs savename
Else
.ActiveDocument.SaveAs2 savename
End If
'closes the doc
.ActiveDocument.Close
'closes word
.Quit
End With
End Sub
One source of help suggested using
`
Sub FnBookMarkInsertAfter()
Dim objWord
Dim objDoc
Dim objRange
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open("C:\xxx\xxx\excel_project\test.docx")
objWord.Visible = True
Set objRange = objDoc.Bookmarks("item").Range
objRange.InsertAfter ("..........I will be added AFTER bookmark")
End Sub
`
This places the string of text into the table and I can’t find a way to make it dynamically select the last row and hence the required data.
Any help would be greatly appreciated
This code inserts an extra row below the last row of a table. The bookmark "Item" must be located inside your table, then this will work. The strings col1 and col2 are inserted in the cells of the new row. Hope this helps you.
Sub InsertTextAtEndOfTable()
Application.ScreenUpdating = False
Dim col1, col2 As String
col1 = "TitleColContent"
col2 = "ValueColContent"
Selection.GoTo What:=wdGoToBookmark, Name:="Item"
Dim tabSize As Integer
tabSize = Selection.Tables(1).Rows.Count
Selection.Tables(1).Cell(1, 1).Select
Dim i As Integer
For i = 1 To tabSize - 1
Selection.MoveDown Unit:=wdLine, Count:=1
Next i
Selection.InsertRowsBelow
Selection.TypeText col1
Selection.MoveRight
Selection.TypeText col2
Application.ScreenUpdating = True
End Sub

Excel VBA: Copy XL named range values to DOC bookmarks, then export to PDF

I'm trying to copy the values from a named range in Excel to a bookmark in Word. I found this code on the web that does it in Excel VBA, but I'm getting an Error 13.
Set pappWord = CreateObject("Word.Application")
Set docWord = pappWord.Documents.Add(Path)
'Loop through names in the activeworkbook
For Each xlName In wb.Names
'if xlName's name is existing in document then put the value in place of the bookmark
If docWord.Bookmarks.Exists(xlName.Name) Then
docWord.Bookmarks(xlName.Name).Range.Text = Range(xlName.Value)
End If
Next xlName
'Activate word and display document
With pappWord
.Visible = True
.ActiveWindow.WindowState = 0
.Activate
End With
I know that the line that is causing the error is:
docWord.Bookmarks(xlName.Name).Range.Text = Range(xlName.Value)
What am i doing wrong? Also, how & where would I code so that I can export the doc to PDF?
Thanks in advance.
Note: I've already selected the reference to the Microsoft Word (version number 14) Object model in Excel
so I use it to accomplish this task but taking an image from formatted Excel table.
Sub FromExcelToWord()
Dim rg As Range
For Each xlName In wb.Names
If docWord.Bookmarks.Exists(xlName.Name) Then
Set rg = Range(xlName.Value)
rg.Copy
docWord.ActiveWindow.Selection.Goto what:=-1, Name:=xlName.Name
docWord.ActiveWindow.Selection.PasteSpecial link:=False, DataType:=wdPasteEnhancedMetafile, Placement:= _
0, DisplayAsIcon:=False
End If
Next xlName
End Sub
Just curious... Why are you adding a document rather than opening the relevant doc which has the bookmarks? Try this code (I usually test the code before posting but I haven't tested this particular code. Just quickly wrote it)
Also I am using Late Binding so no reference to the Word Object Library is required.
Sub Sample()
Dim wb As Workbook
Dim pappWord As Object, docWord As Object
Dim FlName As String
Dim xlName As Name
FlName = "C:\MyDoc.Doc" '<~~ Name of the file which has bookmarks
'~~> Establish an Word application object
On Error Resume Next
Set pappWord = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set pappWord = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
Set docWord = pappWord.Documents.Open(FlName)
Set wb = ActiveWorkbook
For Each xlName In wb.Names
'if xlName's name is existing in document then put the value in place of the bookmark
If docWord.Bookmarks.Exists(xlName.Name) Then
docWord.Bookmarks(xlName.Name).Range.Text = Range(xlName).Value
End If
Next xlName
'Activate word and display document
With pappWord
.Visible = True
.ActiveWindow.WindowState = 0
.Activate
End With
End Sub
EDIT
Changed
Range(xlName.Value)
to
Range(xlName).Value
Now the above code is TRIED AND TESTED :)