HOW To manipulate an ALREADY open word document from excel vba - vba

I am new to VBA and obviously I am missing something. My code works for opening a word doc and sending data to it BUT does NOT for an ALREADY OPEN word doc. I keep searching for an answer on how to send info from Excel to an OPEN Word doc/Bookmark and nothing works.
I hope it is okay that I added all the code and the functions called. I really appreciate your help!
What I have so far
Sub ExcelNamesToWordBookmarks()
On Error GoTo ErrorHandler
Dim wrdApp As Object 'Word.Application
Dim wrdDoc As Object 'Word.Document
Dim xlName As Excel.Name
Dim ws As Worksheet
Dim str As String 'cell/name value
Dim cell As Range
Dim celldata As Variant 'added to use in the test
Dim theformat As Variant 'added
Dim BMRange As Object
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Set wb = ActiveWorkbook
strPath = wb.Path
If strPath = "" Then
MsgBox "Please save your Excel Spreadsheet & try again."
GoTo ErrorExit
End If
'GET FILE & path of Word Doc/Dot
strPathFile = strOpenFilePath 'call a function in MOD1
If strPathFile = "" Then
MsgBox "Please choose a Word Document (DOC*) or Template (DOT*) & try again." 'strPath = Application.TemplatesPath
GoTo ErrorExit
End If
If FileLocked(strPathFile) Then 'Err.Number = 70 if open
'read / write file in use 'do something
'NONE OF THESE WORK
Set wrdApp = GetObject(strPathFile, "Word.Application")
'Set wrdApp = Word.Documents("This is a test doc 2.docx")
'Set wrdApp = GetObject(strPathFile).Application
Else
'all ok 'Create a new Word Session
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
wrdApp.Activate 'bring word visiable so erros do not get hidden.
'Open document in word
Set wrdDoc = wrdApp.Documents.Open(Filename:=strPathFile) 'Open vs wrdApp.Documents.Add(strPathFile)<=>create new Document1 doc
End If
'Loop through names in the activeworkbook
For Each xlName In wb.Names
If Range(xlName).Cells.Count = 1 Then
celldata = Range(xlName.Value)
'do nothing
Else
For Each cell In Range(xlName)
If str = "" Then
str = cell.Value
Else
str = str & vbCrLf & cell.Value
End If
Next cell
'MsgBox str
celldata = str
End If
'Get format and strip away the spacing, negative color etc etc
'I know this is not right... it works but not best
theformat = Application.Range(xlName).DisplayFormat.NumberFormat
If Len(theformat) > 8 Then
theformat = Left(theformat, 5) 'was 8 but dont need cents
Else
'do nothing for now
End If
If wrdDoc.Bookmarks.Exists(xlName.Name) Then
'Copy the Bookmark's Range.
Set BMRange = wrdDoc.Bookmarks(xlName.Name).Range.Duplicate
BMRange.Text = Format(celldata, theformat)
'Re-insert the bookmark
wrdDoc.Bookmarks.Add xlName.Name, BMRange
End If
Next xlName
'Activate word and display document
With wrdApp
.Selection.Goto What:=1, Which:=2, Name:=1 'PageNumber
.Visible = True
.ActiveWindow.WindowState = wdWindowStateMaximize 'WAS 0 is this needed???
.Activate
End With
GoTo WeAreDone
'Release the Word object to save memory and exit macro
ErrorExit:
MsgBox "Thank you! Bye."
Set wrdDoc = Nothing
Set wrdApp = Nothing
Exit Sub
'Error Handling routine
ErrorHandler:
If Err Then
MsgBox "Error No: " & Err.Number & "; There is a problem"
If Not wrdApp Is Nothing Then
wrdApp.Quit False
End If
Resume ErrorExit
End If
WeAreDone:
Set wrdDoc = Nothing
Set wrdApp = Nothing
End Sub
file picking:
Function strOpenFilePath() As String
Dim intChoice As Integer
Dim iFileSelect As FileDialog 'B
Set iFileSelect = Application.FileDialog(msoFileDialogOpen)
With iFileSelect
.AllowMultiSelect = False 'only allow the user to select one file
.Title = "Please... Select MS-WORD Doc*/Dot* Files"
.Filters.Clear
.Filters.Add "MS-WORD Doc*/Dot* Files", "*.do*"
.InitialView = msoFileDialogViewDetails
End With
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strOpenFilePath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
Else
'nothing yet
End If
End Function
checking if file is open...
Function FileLocked(strFileName As String) As Boolean
On Error Resume Next
' If the file is already opened by another process,
' and the specified type of access is not allowed,
' the Open operation fails and an error occurs.
Open strFileName For Binary Access Read Write Lock Read Write As #1
Close #1
' If an error occurs, the document is currently open.
If Err.Number <> 0 Then
' Display the error number and description.
MsgBox "Function FileLocked Error #" & str(Err.Number) & " - " & Err.Description
FileLocked = True
Err.Clear
End If
End Function

ANSWER BELOW. Backstory... So, after input from you guys and more research I discovered that I needed to set the active word document by using the file selection the user picked and that is then passed via late binding to the sub as an object to process. NOW it works if the word file is not in word OR if it is currently loaded into word AND not even the active document. The below code replaces the code in my original question.
Set Object app as word.
grab the file name.
Make the word doc selected active to manipulate.
Set the word object to the active doc.
THANK YOU EVERYONE!
If FileLocked(strPathFile) Then 'Err.Number = 70 if open
'read / write file in use 'do something
Set wrdApp = GetObject(, "Word.Application")
strPathFile = Right(strPathFile, Len(strPathFile) - InStrRev(strPathFile, "\"))
wrdApp.Documents(strPathFile).Activate ' need to set picked doc as active
Set wrdDoc = wrdApp.ActiveDocument ' works!

This should get you the object you need.
Dim WRDFile As Word.Application
Set WRDFile = GetObject(strPathFile)

'Have Microsoft Word 16.0 Object Library selected in your references
Dim wordapp As Object
Set wordapp = GetObject(, "Word.Application")
wordapp.Documents("documentname").Select
'works if you only have one open word document. In my case, I'm trying to push updates to word links from excel.

Related

VBA to Batch Update Folder of MS Word Files with Excel Links

I've got a folder full of MS word docs, all with the same header, containing a couple of fields linked to an excel file to control the project phase and issue date in one spot.
I'm trying to figure out a way to use VBA to loop through all the word docs in this folder, opening them, updating the fields, saving and closing to avoid going through one by one and doing it manually.
Brand new to VBA here and not quite sure what I'm doing (or doing wrong). Here's the code I've pieced together so far based on responses I've seen related to this task. Any help is appreciated on how to improve this/tackle the problem. Happy to provide more info if it helps.
Receiving error "Object variable or With block variable not set" on line "Set oWordDoc = oWordApp.Documents.Open(sFileName)"
Thanks!
Update: Thank you everyone for the help, working code added below.
Sub Sample()
Dim oWordApp As Object, oWordDoc As Object, rngStory As Object
Dim sFolder As String, strFilePattern As String
Dim strFileName As String, sFileName As String
'> Change this to the folder which has the files
sFolder = Dir(Range("A20").Value)
'> This is the extention you want to go in for
strFilePattern = "*.doc"
'> Establish 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
'> Loop through the folder to get the word files
strFileName = Dir$(sFolder & strFilePattern)
Do Until strFileName = ""
sFileName = sFolder & strFileName
'> Open the word doc
Set oWordDoc = oWordApp.Documents.Open(sFileName)
'> Update Fields
oWordDoc.Fields.Update
'> Close the file after saving
oWordDoc.Close SaveChanges:=True
'> Find next file
strFileName = Dir$()
Loop
'> Quit and clean up
oWordApp.Quit
Set oWordDoc = Nothing
Set oWordApp = Nothing
End Sub
Updated Working Code:
Sub UpdateSpecHeaders()
Dim oWordApp As Object, oWordDoc As Object
Dim sFolder As String, strFilePattern As String
Dim strFileName As String, sFileName As String
'> Folder containing files to update
sFolder = Range("A20").Value
'> Identify file extension to search for
strFilePattern = "*.doc"
'> Establish a 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
'> Loop through the folder to get the word files
strFileName = Dir$(sFolder & strFilePattern)
Do Until strFileName = ""
sFileName = sFolder & strFileName
'> Open the word doc
Set oWordDoc = oWordApp.Documents.Open(sFileName)
Application.DisplayAlerts = False
'> Update Fields
oWordApp.ActiveDocument.Fields.Update
'> Save and close the file
oWordDoc.Save
oWordDoc.Close SaveChanges:=True
'> Find next file
strFileName = Dir$()
Loop
'> Quit and clean up
oWordApp.Quit
Set oWordDoc = Nothing
Set oWordApp = Nothing
End Sub

Microsoft Access VBA - Importing data from an unnamed Word Form Field

I have been tasked with importing the contents of a Microsoft Word Form into my Access database. It's working fine using the following VBA code which is triggered from a form:
Private Sub cmdFileDialog_Click()
On Error GoTo ErrorHandler
Dim objDialog As Object
Dim varFile As Variant
Dim rec, rec2 As Recordset
Dim db As Database
'New Word Document Variables
Dim appWord As Word.Application
Dim doc As Word.Document
Const DEST_TABLE = "ap_behaviour_referrals" 'change to suit
Const PATH_DELIM = "\"
Set objDialog = Application.FileDialog(3)
' Clear listbox contents.
Me.fileList.RowSource = ""
With objDialog
.AllowMultiSelect = False
' Set the title of the dialog box.
.Title = "Please select a behaviour referral to import"
' Clear out the current filters, and add our own.
.Filters.Clear
.Filters.Add "Microsoft Word Forms", "*.docx"
.Filters.Add "All Files", "*.*"
.Show
If .SelectedItems.Count = 0 Then
MsgBox "No file selected."
Else
For Each varFile In .SelectedItems
'New docx Variable Actions
Set appWord = GetObject(, "Word.Application")
Set doc = appWord.Documents.Open(varFile)
Next
Set db = CurrentDb
Set rec = db.OpenRecordset(DEST_TABLE)
With rec
.AddNew
' my data
'preformat the date fields from the form
Dim unformattedpupildob As String
Dim formattedpupildob As Date
unformattedpupildob = doc.FormFields("Text2").Result
unformattedpupildob = Replace(unformattedpupildob, ".", "/")
formattedpupildob = Format(unformattedpupildob, "dd/mm/yy")
'And now insert the record into the table
!pupil_name = doc.FormFields("Text1").Result
!pupil_dob = formattedpupildob
!pupil_yr_grp = doc.FormFields("Text3").Result
!pupil_submitted_eth = doc.FormFields("Text4").Result
!pupil_upn = doc.FormFields("Text5").Result
!pupil_looked_after = doc.FormFields("Text6").Result
!sen_pre_statement = doc.FormFields("Text7").Result
!sen_ehcp = doc.FormFields("Text8").Result
!cat_date_final_ehcp = doc.FormFields("Text9").Result
!num_exclusion = doc.FormFields("Text10").Result
!days_exclusion = doc.FormFields("Text11").Result
!sch_name = doc.FormFields("Text12").Result
!sch_no = doc.FormFields("Text14").Result
!contact_name = doc.FormFields("Text13").Result
!contact_role = doc.FormFields("Text40").Result
!contact_email = doc.FormFields("Text31").Result
.Update
.Close
MsgBox "File Processing Complete"
End With
End If
End With
Set objDialog = Nothing
Me.fileList.RowSource = ""
ExitSub:
Set rec = Nothing
Set db = Nothing
'...and set it to nothing
Exit Sub
ErrorHandler:
If Err.Number <> 0 Then
Msg = "Error # " & Str(Err.Number) & " was generated by " & Err.Source & Chr(13) & "Error Line: " & Erl() & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
Resume ExitSub
End Sub
All but one of the fields are (badly) bookmarked so I can use this to grab the contents of the field HOWEVER, I've come across an unnamed form field:
Which I need to import and I have no idea how to get the contents of it without a named bookmark.
I have no ability to modify the form since it's controlled by somebody else and is widely distributed, but was wondering if there was any way to pull the contents of this field without it being named?
Thanks!
Like other collections of objects, you can address them either by name (as you do for the other fields) or by numeric index.
For i = 1 To doc.FormFields.Count
Debug.Print i, doc.FormFields(i).Result
Next i
This should give you the index of the field, if you know its content.
Then use !the_answer = doc.FormFields(42).Result in your code. (42 is an example!)
Edit: minimal working example (running in Access):
Public Sub TestWord()
Dim oWord As Word.Application
Dim oDoc As Word.Document
Dim i As Long
Set oWord = CreateObject("Word.Application")
Set oDoc = oWord.Documents.Open("C:\Users\foobar\Documents\Dok1.docx")
oWord.Visible = True
For i = 1 To oDoc.FormFields.Count
Debug.Print i, oDoc.FormFields(i).Name, oDoc.FormFields(i).Result
Next i
oDoc.Close
oWord.Quit
End Sub
The direct window (Ctrl+g) lists all form fields with their index, name = bookmark, and default text.

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:

.Find not working in Word from Excel vba

I'm trying to get information from a table in Word and pull it into Excel, since the number of tables is variable and I have no other way to reference the table I wanted to find the table directly after the text before it in the document. I've used the .Find method before but for some reason I can't get it to work this time and from everything I've read and used before, this should work:
Sub Process_NIM()
Dim WordPullFile As Object
Dim PullFolder As String
Dim PullDate As Date
Dim AppWord As Word.Application
Dim wd As Word.Document
Dim Table1 As Word.Table
Dim wb As Workbook
Dim ws1, ws2 As Worksheet
Dim Text1 As Word.Range
PullDate = DateAdd("d", 1, Now())
PullFolder = "M:\Production Case Files\" & Format(PullDate, "YYYY") & _
" Production Case Files\" & UCase(Format(PullDate, "MMM")) & _
"\" & UCase(Format(PullDate, "MMM DD")) & "\"
On Error GoTo OpenFileError
Set WordPullFile = Application.FileDialog(msoFileDialogOpen)
With WordPullFile
.AllowMultiSelect = False
.Filters.clear
.Filters.Add "DOC Files (*.doc)", "*.doc"
.InitialFileName = PullFolder
.Show
End With
On Error GoTo 0
If WordPullFile.SelectedItems.Count > 0 Then
PullFolder = WordPullFile.SelectedItems(1)
End If
Set AppWord = CreateObject("Word.Application")
Set wd = AppWord.Documents.Open(PullFolder)
wd.Application.Visible = True
Set wb = ThisWorkbook
Set ws1 = wb.Worksheets(1)
Set ws2 = wb.Worksheets(2)
If Text1.wd.Selection.Find.Execute(findtext:="Generator Outages for Today - Greater than 25MW") = True Then
'do stuff
End If
OpenFileError:
MsgBox ("There was an error opening the word file. Try closing any other instances of word and re-run.")
Exit Sub
End Sub
I use this from Word currently, but I can't get it to work from Excel:
If Text1.Find.Execute(findtext:="RC South Regional Review for") Then
Text1.InsertAfter (" " & Format(FileDate, "MMMM DD, YYYY"))
End If
the good news is, the text you say you use in word that doesn't work in excel, actually does work. The issue is with the value you are trying to put in, I used your code and for a while I was stumped because it appeared to not be working, but when I substituted some plain text instead of your date, it worked fine, whihc told me the find was working. It turns out it simply wasn't resolving Filedate as a date and so wasn't inserting anything. Here is a version of your code, modified to work on my PC that does insert a date after the found string, did you mean to add Pulldate instead of Filedate as the variable to append maybe?
Sub Process_NIM()
Dim WordPullFile As Object
Dim PullFolder As String
Dim PullDate As Date
Dim AppWord As Word.Application
Dim wd As Word.Document
Dim Table1 As Word.Table
Dim wb As Workbook
Dim ws1, ws2 As Worksheet
Dim Text1 As Word.Range
PullDate = DateAdd("d", 1, Now())
PullFolder = "D:\Users\Mark\Documents\"
On Error GoTo OpenFileError
Set WordPullFile = Application.FileDialog(msoFileDialogOpen)
With WordPullFile
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "DOC Files (*.doc)", "*.doc"
.InitialFileName = PullFolder
.Show
End With
On Error GoTo 0
If WordPullFile.SelectedItems.Count > 0 Then
PullFolder = WordPullFile.SelectedItems(1)
End If
Set AppWord = CreateObject("Word.Application")
Set wd = AppWord.Documents.Open(PullFolder)
wd.Application.Visible = True
Set wb = ThisWorkbook
Set ws1 = wb.Worksheets(1)
Set ws2 = wb.Worksheets(2)
Set Text1 = wd.Range
If Text1.Find.Execute(findtext:="RC South Regional Review for") Then
Text1.InsertAfter (" " & Format(Date, "MMMM DD, YYYY"))
Else
MsgBox "could not find text"
End If
wd.Save
wd.Close
AppWord.Quit
Set AppWord = Nothing
Exit Sub
OpenFileError:
MsgBox ("There was an error opening the word file. Try closing any other instances of word and re-run.")
Exit Sub
End Sub

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.