Search word doc for text and paste into excel file - vba

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:

Related

HOW To manipulate an ALREADY open word document from excel 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.

Paste multiple sheets into a single Word document

I'm trying to copy and paste each worksheet in a workbook onto a new sheet in a single Word document. Unfortunately it is only copying the contents of the first worksheet, though it does seem to be looping through all the worksheets. I thought that inserting a page break would work but it isn't. It also won't let me format it in Word. I want the contents of A1 to have a header style.
This is my code:
Sub ExceltoWord()
Dim ws As Worksheet
Dim Wkbk1 As Workbook
Set Wkbk1 = ActiveWorkbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
For Each ws In Wkbk1.Worksheets
Wkbk1.ActiveSheet.Range("A1:A2").Copy
Dim wdapp As Object
Dim wddoc As Object
Dim Header As Range
'file name & folder path
Dim strdocname As String
On Error Resume Next
'error number 429
Set wdapp = GetObject(, "Word.Application")
If Err.Number = 429 Then
Err.Clear
'create new instance of word application
Set wdapp = CreateObject("Word.Application")
End If
wdapp.Visible = True
'define paths to file
strdocname = "P:\ImportedDescriptions.doc"
If Dir(strdocname) = "" Then
MsgBox "The file" & strdocname & vbCrLf & "was not found " & vbCrLf & "P:\ImportedDescriptions.doc", vbExclamation, "The document does not exist "
Exit Sub
End If
wdapp.Activate
Set wddoc = wdapp.Documents(strdocname)
If wddoc Is Nothing Then Set wddoc = wdapp.Documents.Open(strdocname)
Set Header = Range("A1")
'must activate to be able to paste
wddoc.Activate
wddoc.Range.Paste
Selection.WholeStory
Header.Style = ActiveDocument.Styles("Heading 2")
Selection.InsertBreak Type:=wdPageBreak
Next ws
wddoc.Save
'wdapp.Quit
Set wddoc = Nothing
Set wdapp = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
You are only copying from the active worksheet, which happens to be the first sheet in your case. Instead of:
For Each ws In ActiveWorkbook.Worksheets
ActiveWorkbook.ActiveSheet.Range("A1:A2").Copy
use:
For Each ws In ActiveWorkbook.Worksheets
ws.Range("A1:A2").Copy
This will copy each range in turn.
I think it is losing track of which workbook you started with when you activate Word. Save your workbook to a Workbook variable (i.e. Dim Wkbk1 As Workbook, Set Wkbk1 = ActiveWorkbook) then replace every instance of ActiveWorkbook in your code after that with Wkbk1 (in your For Each loop and every time you want to reference it inside the loop as well).

.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

VBA Subscript out of range and Error 9

I know this error has been defined in earlier posts for e.g. here. I am pretty new to VBA and do not really understand the explanation there.
I am using the following code to automate adding multiple tables to a word document by bookmarking them as explained in the link http://www.thespreadsheetguru.com/blog/2014/10/5/multiple-tables-to-word-with-vba.I am getting a Subscript out of range (error 9)
The tables are created in the same sheet manually by myself by selecting a particular range in the excel sheet.
Here below you can find the code. I would really be grateful if someone can identify where I am going wrong.
Thank you very much in advance.
Option Base 1 'Force arrays to start at 1 instead of 0
Sub ExcelTablesToWord()
'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 WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table
Dim TableArray As Variant
Dim BookmarkArray As Variant
'List of Table Names (To Copy)
TableArray = Array("Table1", "Table2", "Table3", "Table4", "Table5")
'List of Word Document Bookmarks (To Paste To)
BookmarkArray = Array("Bookmark1", "Bookmark2", "Bookmark3", "Bookmark4", "Bookmark5")
'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("Siko_LEFIS_v0.1.docx")
On Error GoTo 0
'Loop Through and Copy/Paste Multiple Excel Tables
For x = LBound(TableArray) To UBound(TableArray)
'Copy Table Range from Excel
tbl = ThisWorkbook.Worksheets(x).ListObjects(TableArray(x)).Range '####Here is where i get the subbscipt out of range error#######
tbl.Copy
'Paste Table into MS Word (using inserted Bookmarks -> ctrl+shift+F5)
myDoc.Bookmarks(BookmarkArray(x)).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
'Autofit Table so it fits inside Word Document
Set WordTable = myDoc.Tables(x)
WordTable.AutoFitBehavior (wdAutoFitWindow)
Next x
'Completion Message
MsgBox "Copy/Pasting Complete!", vbInformation
GoTo EndRoutine
'ERROR HANDLER
WordDocNotFound:
MsgBox "Microsoft Word file 'Siko_LEFIS_v0.1.docx' 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 below (some slight tweaks for my environment) worked for me. Most likely cause of your error was that you don't have a table with the expected name on one of your sheets.
You were also missing Set on that line (required when assigning a value to an object variable)
Option Explicit
Option Base 1 'Force arrays to start at 1 instead of 0
Sub ExcelTablesToWord()
Dim tbl As Excel.Range
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table
Dim TableArray As Variant
Dim BookmarkArray As Variant
Dim x As Long, sht As Worksheet
TableArray = Array("Table1", "Table2")
BookmarkArray = Array("Bookmark1", "Bookmark2")
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo WordDocNotFound
Set WordApp = GetObject(class:="Word.Application")
WordApp.Visible = True
Set myDoc = WordApp.Activedocument
'Set myDoc = WordApp.Documents("Siko_LEFIS_v0.1.docx")
On Error GoTo 0
For x = LBound(TableArray) To UBound(TableArray)
Set sht = ThisWorkbook.Worksheets(x)
Set tbl = sht.ListObjects(TableArray(x)).Range
myDoc.Bookmarks(BookmarkArray(x)).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
Set WordTable = myDoc.Tables(x)
WordTable.AutoFitBehavior (wdAutoFitWindow)
Next x
'Completion Message
MsgBox "Copy/Pasting Complete!", vbInformation
GoTo EndRoutine
'ERROR HANDLER
WordDocNotFound:
MsgBox "Microsoft Word file 'Siko_LEFIS_v0.1.docx' 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
I would also recommend that you try to avoid using the Option Base 1 setting: it might appear to make dealing with arrays easier, but changing the default array behavior causes more problem than it solves.

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.