Delete row when fields are empty - vba

I am trying to use Visual Basic so that I can populate word templates with data from excel. I have a macro that fills in fields in a Word document table from a table in Microsoft Excel. So far, if the excel table is smaller than the word table, the message "Error! No document variable supplied" prints in the word table and I delete that field using the macro (below). BUT, I also want to delete the entire rows in the Word table where this error occurs. Can you help me figure out how to do this?
Sub Rectangle_Click()
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim ws As Worksheet
Dim oHeader As Word.HeaderFooter
Dim oSection As Word.Section
Dim oFld As Word.Field
Dim flds As Word.Fields
Dim fld As Word.Field
Set ws = ThisWorkbook.Sheets("Sheet1")
ws.Activate
On Error Resume Next
Set wrdApp = GetObject(, "Word.Application")
If wrdApp Is Nothing Then Set wrdApp = CreateObject("Word.Application")
On Error GoTo 0
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Add(Template:="C:\Documents\mytemplate.dotm")
With wrdDoc
.Variables("foo1").Value = Range("A5").Value
.Variables("foo2").Value = Range("A6").Value
.Variables("foo3").Value = Range("A7").Value
.Variables("bar1").Value = Range("B5").Value
.Variables("bar2").Value = Range("B6").Value
.Variables("bar3").Value = Range("B7").Value
.Range.Fields.Update
End With
wrdDoc.Range.Fields.Update
Set flds = ActiveDocument.Fields
For Each fld In flds
If fld.Type = wdFieldDocVariable Then
If fld.Result = "Error! No document variable supplied." Then
Debug.Print fld.Code
'ALSO DELETE THE ROW WHERE THIS EMPTY FIELD WAS FOUND!!'
fld.Delete
End If
End If
Next
Set wrdDoc = Nothing
Set wrdApp = Nothing
Application.CutCopyMode = False
End Sub
How can I get rid of rows (or cells) where "no document variable supplied" occurs?

If you want to delete the whole row of table where your current selection is then use:
Word.Selection.Rows.Delete

Related

How to integrate the excel range into one single table?

I have two ranges in the excel file .
(A79-I84) & (A90-I92)
I am now using the Excel.RANGE.copy. to copy the two tables and paste on the word file .
However , the two ranges become two separate tables and the original excel table format cannot inherit to the new word file .Also , some cells from the word report will be shown in two lines .
In conclusion , the format of the word report will be very messy .
How to integrate the two table into one table with good table format or alignments?
the new table will be generated like this :
(red pen = problems )
My codes:
Sub ExcelRangeToWord()
Dim tbl0 As Excel.RANGE
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 tbl0 = ThisWorkbook.Worksheets(sheet9.Name).RANGE("A78:I83")
Set tbl = ThisWorkbook.Worksheets(sheet9.Name).RANGE("A78:I83")
Set tbl2 = ThisWorkbook.Worksheets(sheet9.Name).RANGE("A90:I92")
'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
'Trigger copy separately for each table + paste for each table
tbl.Copy ' paste range1
myDoc.Paragraphs(1).RANGE.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=True, _
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:=True, _
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
new aftereffect
Try the following. Simply hide rows in between (which ever you don't want to see) and copy as one range to be from "A79:I92" and paste as a picture. Credit here (#sneep) for sub to resize image. Note this will resize all images but could be adapted to target just one.
Option Explicit
Sub ExcelRangeToWord()
Dim tbl0 As Excel.Range
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
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet2") ' Change e.g. sheet9.Name
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
ws.Rows("84:89").EntireRow.Hidden = True 'ADJUST AS APPROPRIATE
'Copy Range from Excel
'Set tbl0 = ws.RANGE("A78:I83")
Set Tbl = ws.Range("A78:I92")
' Set tbl2 = ws.Range("A90:I92")
'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
'Trigger copy separately for each table + paste for each table
Tbl.CopyPicture Appearance:=xlScreen, Format:=xlPicture
wordApp.Selection.Paste
wordApp.Selection.TypeParagraph
wordApp.Selection.PageSetup.Orientation = wdOrientLandscape
resize_all_images_to_page_width myDoc
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
Sub resize_all_images_to_page_width(myDoc As Document)
'https://blog.qiqitori.com/?p=115
Dim inline_shape As InlineShape
Dim percent As Double
For Each inline_shape In myDoc.InlineShapes
inline_shape.LockAspectRatio = msoFalse
inline_shape.ScaleWidth = 100
inline_shape.ScaleHeight = 100
percent = myDoc.PageSetup.TextColumns.Width / inline_shape.Width
inline_shape.ScaleWidth = percent * 100
inline_shape.ScaleHeight = percent * 100
Next
End Sub

Excel VBA copy pasting each named range to word

I have dynamic named range of cell. I need to paste each named range in one page of word and move to next page for next named range. I tried copule of code, I am unable to do.Each named range data is overlapping each other. Can anyone help me, please.
Set wbBook = ActiveWorkbook
Set rs = wbBook.Names(1).RefersToRange
For i = 2 To wbBook.Names.Count
Set rs = Union(rs, wbBook.Names(i).RefersToRange)
Next
rs.Copy
With wd.Range
.Collapse Direction:=0
.InsertParagraphAfter
.Collapse Direction:=0
.PasteSpecial False, False, True
Application.CutCopyMode = False
End With
It sounds like you want to copy each range onto different pages so I'm not sure why you're using a union. Here is a quick example of copying each named range 'name' onto a new sheet in a word document. Note: I created a new doc for simplicity.
Edit - I added copy/paste functionality of data to the end. Formatting and such depends on what you have or want.
Sub main()
'Create new word document
Dim objWord As Object
Dim objDoc As Object
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objDoc = objWord.documents.Add()
Dim intCounter As Integer
Dim rtarget As Word.Range
Dim wbBook As Workbook
Set wbBook = ActiveWorkbook
'Loop Through names
For intCounter = 1 To wbBook.Names.Count
Debug.Print wbBook.Names(intCounter)
With objDoc
Set rtarget = .Range(.Content.End - 1, .Content.End - 1)
'Insert page break if not first page
If intCounter > 1 Then rtarget.insertbreak Type:=wdPageBreak
'Write name to new page of word document
rtarget.Text = wbBook.Names(intCounter).Name & vbCr
'Copy data from named range
Range(wbBook.Names(intCounter)).Copy
Set rtarget = .Range(.Content.End - 1, .Content.End - 1)
rtarget.Paste
End With
Next intCounter
End Sub
Excel
Resulting Word Document
I don't think this is the best solution out there (as I don't normally play with Word VBA) but I have tried this and it does seems to work:
Sub AddNamedRangesToWordDoc()
Dim oWord As Word.Application
Dim oDoc As Word.Document
Dim intCount As Integer
Dim oRng As Range
Dim oSelection As Object
Set oWord = New Word.Application
Set oDoc = oWord.Documents.Add
oWord.Visible = True
For intCount = 1 To ActiveWorkbook.Names.Count
Set oRng = Range(ActiveWorkbook.Names(intCount).RefersToRange.Name.Name)
oRng.Copy
oDoc.ActiveWindow.Selection.PasteSpecial , , 0
Set oSelection = oWord.Selection
oSelection.InsertBreak (wdPageBreak)
Next
Set oSelection = Nothing
Set oRng = Nothing
Set oDoc = Nothing
Set oWord = Nothing
End Sub
NOTE: I am creating a new word application. You might have to check if word is already open and how you want to deal with an existing word doc. Also, I'm not creating the word object. I have Microsoft Word xx.x Object Library referenced in the project as I prefer to work with built in libraries. Also, function presumes that you only have 1 worksheet and all your ranges are in that worksheet

Trying to copy data from several ranges in Excel to MS Word

I'm playing around with this code snippet, which I found on SO.
Sub Test()
Dim objWord As Object
Dim ws As Worksheet
Set ws1 = ThisWorkbook.Sheets("Contact Information1")
Set ws2 = ThisWorkbook.Sheets("Contact Information2")
'Set ws3 = ThisWorkbook.Sheets("Contact Information3")
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Open "C:\Users\rshuell001\Desktop\Final Report.docx" ' change as required
With objWord.ActiveDocument
.Bookmarks("BkMark1").Range.Text = ws1.Range("A1:F24").Value
.Bookmarks("BkMark2").Range.Text = ws2.Range("A1:F8").Value
'.Bookmarks("Report3").Range.Text = ws3.Range("A1:F80").Value
End With
Set objWord = Nothing
End Sub
When I look at it, it makes sense. When I run the script, I get an error on this line:
.Bookmarks("BkMark1").Range.Text = ws1.Range("A1:F24").Value
The error message is:
Run-type error 13
Type mismatch
1) I'm not sure '.Bookmarks("BkMark1").Range.Text' will do what I want. I think it's more of a standard copy/paste.
2) I want to make sure the table fits in the Word document, so I'm going to need something like the line below, to get it to do what I want.
wd.Tables(1).AutoFitBehavior wdAutoFitWindow
Any ideas on how to make this work?
Thanks!
I came up with the script below. It does what I want.
Sub Export_Table_Word()
'Name of the existing Word doc.
'Const stWordReport As String = "Final Report.docx"
'Word objects.
Dim WDApp As Word.Application
Dim WDDoc As Word.Document
Dim wdbmRange1 As Word.Range
'Excel objects.
Dim wbBook As Workbook
Dim wsSheet1 As Worksheet
Dim rnReport1 As Range
'Initialize the Excel objects.
Set wbBook = ThisWorkbook
Set WDApp = New Word.Application
'Set wdDoc = wdApp.Documents.Open(wbBook.Path & "\" & stWordReport)
Set WDDoc = WDApp.Documents.Open("C:\Users\rshuell001\Desktop\Final Report.docx")
'Delete old fields and prepare to replace with new
Dim doc As Document
Dim fld As Field
Set doc = WDDoc
For Each fld In doc.Fields
fld.Select
If fld.Type = 88 Then
fld.Delete
End If
Next
Set wsSheet = wbBook.Worksheets("Contact Information1")
Set rnReport = wsSheet.Range("BkMark1")
Set wdbmRange = WDDoc.Bookmarks("BkMark1").Range
'Turn off screen updating.
Application.ScreenUpdating = False
'Copy the report to the clipboard.
rnReport.Copy
'Select the range defined by the "Report" bookmark and paste in the report from clipboard.
With wdbmRange
.Select
.Paste
End With
WDDoc.Tables(1).AutoFitBehavior wdAutoFitWindow
Set wsSheet = wbBook.Worksheets("Contact Information2")
Set rnReport = wsSheet.Range("BkMark2")
Set wdbmRange = WDDoc.Bookmarks("BkMark2").Range
Application.ScreenUpdating = False
rnReport.Copy
With wdbmRange
.Select
.Paste
End With
WDDoc.Tables(2).AutoFitBehavior wdAutoFitWindow
Set wsSheet = wbBook.Worksheets("Contact Information3")
Set rnReport = wsSheet.Range("BkMark3")
Set wdbmRange = WDDoc.Bookmarks("BkMark3").Range
Application.ScreenUpdating = False
rnReport.Copy
With wdbmRange
.Select
.Paste
End With
WDDoc.Tables(3).AutoFitBehavior wdAutoFitWindow
'Save and close the Word doc.
With WDDoc
.Save
.Close
End With
'Quit Word.
WDApp.Quit
'Null out your variables.
Set fld = Nothing
Set doc = Nothing
Set wdbmRange = Nothing
Set WDDoc = Nothing
Set WDApp = Nothing
'Clear out the clipboard, and turn screen updating back on.
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
MsgBox "The report has successfully been " & vbNewLine & _
"transferred to " & stWordReport, vbInformation
End Sub

Search word doc for text and paste into excel file

I'm pretty sure I'm real close on this one, I used a combination of this question for text selection and this other question regarding importing tables for what I've gotten so far.
I'm trying to find certain value in a word file, with the most identifiable preceding text being a "VALUE DATE" on the line above it. The value I want is in the line below this "VALUE DATE". I want the macro to be able to search the word doc for the desired text and paste it into excel, as normally we would have to do this manually about 50 times. Very tedious.
For reference here's what the text looks like in the word doc.
TRANSACTIONS VALUE DATE
31-08-15 X,XXX.XX
I want to pull value X,XXX.XX and paste it into a destination in excel, let's just use A1 for simplicity.
Sub wordscraper9000()
Dim oWordApp As Object, oWordDoc As Object
Dim FlName As String
'''''dim tbl as object --> make string
Dim TextToFind As String, TheContent As String
Dim rng1 As Word.Range
FlName = Application.InputBox("Enter filepath of .doc with desired information")
'establish word app object
On Error Resume Next
Set oWordApp = GetObject(, "Word.application")
If Err.Number <> 0 Then
Set oWordApp = CreateObject("Word.application")
End If
Err.Clear
On Error GoTo 0
oWordApp.Visible = True
'open word doc
Set oWordDoc = oWordApp.documents.Open(FlName)
'--> enter something that will skip if file already open
'''''set tbl = oworddoc.tables(1) --> set word string
'declare excel objects
Dim wb As Workbook, ws As Worksheet
'Adding New Workbook
Set wb = Workbooks.Add
'Saving the Workbook
ActiveWorkbook.SaveAs "C:\Users\iansch\Desktop\DummyWB.xlsx"
Set ws = wb.Sheets(1)
'what text to look for
TextToFind = "VALUE DATE"
'''''problems here below
Set rng1 = oWordApp.ActiveDocument.Content
rng.Find.Execute findtext:=TextToFind, Forward:=True
If rng1.Find.found Then
If rng1.Information(wdwithintable) Then
TheContent = rng.Cells(1).Next.Range.Text 'moves right on row
End If
Else
MsgBox "Text '" & TextToFind & "' was not found!"
End If
'copy text range and paste into cell A1
'tbl.range.copy
ws.Range("A1").Activate
ws.Paste
End Sub
At the line
set rng1.oWordApp.ActiveDocument.Content
I get a run-time 8002801d error - automation error, library not registered.
I couldn't find anything on here that was perfect for my case, however the 2nd question I linked to is very, very close to what I want, however I'm trying to import text rather than a table.
This will extract the "X,XXX.XX" value into a new Excel file, sheet 1, cell A1:
Option Explicit
Public Sub wordscraper9000()
Const FIND_TXT As String = "VALUE DATE"
Const OUTPUT As String = "\DummyWB.xlsx"
Dim fName As Variant, wrdApp As Object, wrdTxt As Variant, sz As Long, wb As Workbook
fName = Application.GetOpenFilename("Word Files (*.Doc*),*.Doc*", , _
"Enter filepath of .doc with desired information")
If fName <> False Then
'get Word text --------------------------------------------------------------------
On Error Resume Next
Set wrdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set wrdApp = CreateObject("Word.Application")
Err.Clear
End If: wrdApp.Visible = False
wrdTxt = wrdApp.Documents.Open(fName).Content.Text: wrdApp.Quit
'get value ------------------------------------------------------------------------
sz = InStr(1, wrdTxt, FIND_TXT, 1)
If Len(sz) > 0 Then
wrdTxt = Trim(Right(wrdTxt, Len(wrdTxt) - sz - Len(FIND_TXT)))
wrdTxt = Split(Trim(Right(wrdTxt, InStr(wrdTxt, " "))))(0)
'save to Excel ----------------------------------------------------------------
Set wb = Workbooks.Add
wb.Sheets(1).Cells(1, 1) = wrdTxt
Application.DisplayAlerts = False
wb.Close True, CreateObject("WScript.Shell").SpecialFolders("Desktop") & OUTPUT
Application.DisplayAlerts = True
End If
End If
End Sub
.
This code is specific to this pattern:
"Reference" (any # of spaces) (any word without a space) (any # of spaces) "ExtractValue"
Search for reference (FIND_TXT)
Find and skip the next word (text without a space in it) after any number of spaces or empty lines
Extract the second word, separated by any number of spaces or lines from the skipped first word
Modifying your code a bit and if the information you want is in a fixed position within a Word table, you can do this:
Sub wordscraper90000()
Dim oWordApp As Object, oWordDoc As Object
Dim FlName As String
Dim TheContent As String
FlName = Application.GetOpenFilename("Word Files (*.Doc*),*.Doc*", , _
"Enter filepath of .doc with desired information")
'establish word app object
On Error Resume Next
Set oWordApp = GetObject(, "Word.application")
If Err.Number <> 0 Then
Set oWordApp = CreateObject("Word.application")
End If
Err.Clear
On Error GoTo 0
oWordApp.Visible = True
'open word doc
Set oWordDoc = oWordApp.Documents.Open(FlName)
'declare excel objects
Dim wb As Workbook, ws As Worksheet
'Adding New Workbook
Set wb = Workbooks.Add
'Saving the Workbook
ActiveWorkbook.SaveAs "C:\Users\iansch\Desktop\DummyWB.xlsx"
Set ws = wb.Sheets(1)
TheContent = oWordDoc.Tables.Item(1).Cell(2, 3).Range.Text
ws.Range("A1").Activate
ws.Range("A1").Value = Trim(Replace(TheContent, Chr(7), Chr(32))) 'Remove strange character at the end
End Sub
Whereas the data to be extracted it is in row 2, column 3:

How to preserve source formatting while copying data from word table to excel sheet using VB macro?

I am trying to copy some data from a word table to an excel sheet using a VB Macro.
It is copying the text perfectly as desired.
Now i want to preserve the source formatting present in word doc.
The things I want to preserve are
Strike Through
Color
Bullets
New Line Character
I am using the following code to copy -
objTemplateSheetExcelSheet.Cells(1, 2) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
Kindly let me know how I can edit this so as to preserve source formatting.
The logic I am using is as follows -
wdFileName = Application.GetOpenFilename("Word files (*.*),*.*", , _
"Browse for file containing table to be imported") '(Browsing for a file)
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) '(open Word file)
With wdDoc
'enter code here`
TableNo = wdDoc.tables.Count '(Counting no of tables in the document)
If TableNo = 0 Then
MsgBox "This document contains no tables", _
vbExclamation, "Import Word Table"
End If
End With
I am running a table count on the word file. Then for all the tables present in the word doc accessing each row and column of the tables using the above mentioned code.
Ok I am attaching the remaining piece of code as well
'Creating TemplateSheet object
Set objTemplateSheetExcelApp = CreateObject("Excel.Application")
'Opening the template to be used
objTemplateSheetExcelApp.Workbooks.Open ("C:\Temp\Documents Page XX_US-VC Combo Template.xlsx")
Set objTemplateSheetExcelWkBk = objTemplateSheetExcelApp.ActiveWorkbook.Worksheets(5)
Set objTemplateSheetExcelSheet = objTemplateSheetExcelApp.ActiveWorkbook.Worksheets(5) '(Selecting the desired tab)
tblcount = 1
For tblcount = 1 To TableNo
With .tables(tblcount)
'copy cell contents from Word table cells to Excel cells
For iRow = 1 To .Rows.Count
For iCol = 1 To .Columns.Count
On Error Resume Next
strEach = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
For arrycnt = 0 To 15
YNdoc = InStr(strEach, myArray(arrycnt))
If (YNdoc > 0) Then
objTemplateSheetExcelSheet.Cells(2, yourArray(arrycnt)) = _
WorksheetFunction.Clean(.cell(iRow, iCol + 1).Range.Text)
If arrycnt = 3 Or arrycnt = 6 Then
objTemplateSheetExcelSheet.Cells(2, yourArray(arrycnt) + 1) = _
WorksheetFunction.Clean(.cell(iRow + 1, iCol + 1).Range.Text)
End If
End If
Next arrycnt
Next iCol
Next iRow
End With
Next tblcount
End With
intRow = 1
'To save the file
strFileName = "Newfile.xlsx"
objTemplateSheetExcelWkBk.SaveAs strFld & "\" & strFileName
objTemplateSheetExcelApp.Quit
Set objTemplateSheetExcelApp = Nothing
Set objTemplateSheetExcelWkBk = Nothing
Set objTemplateSheetExcelSheet = Nothing
Set wdDoc = Nothing
To interact with Word from Excel, you can choose either Early Binding or Late Binding. I am using Late Binding where you do not need to add any references.
I will cover the code in 5 parts
Binding with a Word Instance
Opening the Word document
Interacting with Word Table
Declaring Your Excel Objects
Copying the word table to Excel
A. Binding with a Word Instance
Declare your Word objects and then bind with either an existing instance of Word or create a new instance. For example
Sub Sample()
Dim oWordApp As Object, oWordDoc As Object
'~~> Establish an Word application object
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set oWordApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
oWordApp.Visible = True
End Sub
B. Opening the Word document
Once you have connected with/created the Word instance, simply open the word file.. See this example
Sub Sample()
Dim oWordApp As Object, oWordDoc As Object
Dim FlName As String
FlName = Application.GetOpenFilename("Word files (*.Doc*),*.Doc*", , _
"Browse for file containing table to be imported")
'~~> Establish an Word application object
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set oWordApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
oWordApp.Visible = True
'~~> Open the Word document
Set oWordDoc = oWordApp.Documents.Open(FlName)
End Sub
C. Interacting with Word Table
Now you have the document open, Let's connect with say Table1 of the word document.
Sub Sample()
Dim oWordApp As Object, oWordDoc As Object
Dim FlName As String
Dim tbl As Object
FlName = Application.GetOpenFilename("Word files (*.Doc*),*.Doc*", , _
"Browse for file containing table to be imported")
'~~> Establish an Word application object
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set oWordApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
oWordApp.Visible = True
Set oWordDoc = oWordApp.Documents.Open(FlName)
Set tbl = oWordDoc.Tables(1)
End Sub
D. Declaring Your Excel Objects
Now we have the handle to the Word Table. Before we copy it, let's set our Excel objects.
Sub Sample()
Dim oWordApp As Object, oWordDoc As Object
Dim FlName As String
Dim tbl As Object
FlName = Application.GetOpenFilename("Word files (*.Doc*),*.Doc*", , _
"Browse for file containing table to be imported")
'~~> Establish an Word application object
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set oWordApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
oWordApp.Visible = True
Set oWordDoc = oWordApp.Documents.Open(FlName)
Set tbl = oWordDoc.Tables(1)
'~~> Excel Objects
Dim wb As Workbook, ws As Worksheet
Set wb = Workbooks.Open("C:\Temp\Documents Page XX_US-VC Combo Template.xlsx")
Set ws = wb.Sheets(5)
End Sub
E. Copying the word table to Excel
And finally when we have the destination all set, simply copy the table from word to Excel. See this.
Sub Sample()
Dim oWordApp As Object, oWordDoc As Object
Dim FlName As String
Dim tbl As Object
FlName = Application.GetOpenFilename("Word files (*.Doc*),*.Doc*", , _
"Browse for file containing table to be imported")
'~~> Establish an Word application object
On Error Resume Next
Set oWordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set oWordApp = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
oWordApp.Visible = True
Set oWordDoc = oWordApp.Documents.Open(FlName)
Set tbl = oWordDoc.Tables(1)
'~~> Excel Objects
Dim wb As Workbook, ws As Worksheet
Set wb = Workbooks.Open("C:\Temp\Documents Page XX_US-VC Combo Template.xlsx")
Set ws = wb.Sheets(1)
tbl.Range.Copy
ws.Range("A1").Activate
ws.Paste
End Sub
SCREENSHOT
Word Document
Excel (After Pasting)
Hope this helps.