How to add rows to a merged Word table? - vba

This is how the table looks like.
Code:
Sub WordTableTester()
Dim CurrentTable As table
Dim wdDoc As Document
Dim Rw As Long, col As Long
Dim wdFileName
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , "Please choose a file containing requirements to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
With wdDoc
Set CurrentTable = wdDoc.Tables(1)
Rw = 9: col = CurrentTable.Columns.Count
wdDoc.Range(CurrentTable.Cell(Rw, 1).Range.start, _
CurrentTable.Cell(Rw, col).Range.start).Select
wdDoc.Application.Selection.InsertRowsBelow
End With
End Sub
When I run this, I get the an error message: Run-Time error '5941': The requested member of the collection does not exist.
Note: I'm running a VBA Excel Macro and importing/adding rows to a table in a Word Doc

Working with merged rows in MS Word Table is slightly tricky.
Is this what you want?
Sub Sample()
Dim CurrentTable As Table
Dim wdDoc As Document
Dim Rw As Long, col As Long
Set wdDoc = ActiveDocument '<~~ Created this for testing
Set CurrentTable = wdDoc.Tables(1)
Rw = 9: col = CurrentTable.Columns.Count
wdDoc.Range(CurrentTable.Cell(Rw, 1).Range.Start, _
CurrentTable.Cell(Rw, col).Range.Start).Select
wdDoc.Application.Selection.InsertRowsBelow
End Sub
ScreenShot
Edit
You table's format is all screwed up. Table was created with few rows and then the cells were merged/split to create new rows and hence you were getting the error. Also since you are automating word from excel, I would recommend the following way.
Try this
Sub WordTableTester()
Dim oWordApp As Object, oWordDoc As Object, CurrentTable As Object
Dim flName As Variant
Dim Rw As Long, col As Long
flName = Application.GetOpenFilename("Word files (*.docx),*.docx", _
, "Please choose a file containing requirements to be imported")
If flName = False Then Exit Sub
Set oWordApp = CreateObject("Word.Application")
oWordApp.Visible = True
Set oWordDoc = oWordApp.Documents.Open(flName)
Set CurrentTable = oWordDoc.Tables(1)
Rw = 7: col = CurrentTable.Columns.Count
oWordDoc.Range(CurrentTable.Cell(Rw, 1).Range.Start, _
CurrentTable.Cell(Rw, col).Range.Start).Select
oWordDoc.Application.Selection.InsertRowsBelow
End Sub

Related

Copy range in Word avoiding clipboard

I have the code below to copy an array of tables in Word to Excel. The volume of data being copied gives memory problems, so I would like to avoid the clipboard - i.e. avoid using Range.Copy
Word does not support Range.Value and I have not been able to get Range(x) = Range(y) to work.
Any suggestions for a way to avoid the clipboard? Word formatting can be junked.
Sub ImportWordTableArray()
Dim WordApp As Object
Dim WordDoc As Object
Dim arrFileList As Variant, FileName As Variant
Dim tableNo As Integer 'table number in Word
Dim tableStart As Integer
Dim tableTot As Integer
Dim Target As Range
On Error Resume Next
arrFileList = Application.GetOpenFilename("Word files (*.doc; *.docx),*.doc;*.docx", 2, _
"Browse for file containing table to be imported", , True)
If Not IsArray(arrFileList) Then Exit Sub
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
Worksheets("Test").Range("A:AZ").ClearContents
Set Target = Worksheets("Test").Range("A1")
For Each FileName In arrFileList
Set WordDoc = WordApp.Documents.Open(FileName, ReadOnly:=True)
With WordDoc
'For array
Dim tables() As Variant
Dim tableCounter As Long
tableNo = WordDoc.tables.Count
tableTot = WordDoc.tables.Count
If tableNo = 0 Then
MsgBox WordDoc.Name & "Contains no tables", vbExclamation, "Import Word Table"
End If
tables = Array(1, 3, 5) '<- define array manually here if not using InputBox
For tableCounter = LBound(tables) To UBound(tables)
With .tables(tables(tableCounter))
.Range.Copy
Target.Activate
'Target.Parent.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:=False '<- memory problems!
'Or
ActiveSheet.Paste '<- pastes with formatting
Set Target = Target.Offset(.Rows.Count + 2, 0)
End With
Next tableCounter
.Close False
End With
Next FileName
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub
You may need to tweak the code below to get it to do exactly what you want (Excel is not something I use often) as the calculation of ranges is a bit wonky, but it will transfer text from word to excel without cutting and pasting
Option Explicit
' This code is based on it being in an Excel VBA Module with the reference
' to the Microsoft Word Object XX.X Object Library (Tools.References)
' enabled so that we get intellisense for Word objects
Public Enum ImportError
NoTablesInDocument
End Enum
Sub ImportWordTableArray()
Dim myFileList As Variant
If Not TryGetFileList(myFileList) Then Exit Sub
Dim myWdApp As Word.Application
Set myWdApp = New Word.Application
myWdApp.Visible = True
If Application.ReferenceStyle = xlA1 Then Application.ReferenceStyle = xlR1C1
ThisWorkbook.Worksheets("Test").Range("A:AZ").ClearContents
Dim myFileName As Variant
For Each myFileName In myFileList
Dim myDoc As Word.Document
If TryGetWordDoc(myFileName, myWdApp, myDoc) Then
CopyDocTablesToExcel myDoc, ThisWorkbook.Worksheets("Test")
End If
Next
If Application.ReferenceStyle = xlR1C1 Then Application.ReferenceStyle = xlA1
End Sub
Public Sub CopyDocTablesToExcel(ByVal ipDoc As Word.Document, ByVal ipWs As Excel.Worksheet)
If ipDoc.Tables.Count = 0 Then
Report ipDoc.Name, ImportError.NoTablesInDocument
Exit Sub
End If
Dim myTable As Variant
Dim Target As Excel.Range
For Each myTable In ipDoc.Tables
' This code assumes that the Word table is 'uniform'
Dim myCols As Long
myCols = myTable.Range.Tables.Item(1).Range.Columns.Count
Dim myRows As Long
myRows = myTable.Range.Tables.Item(1).Range.Rows.Count
Dim myTLCell As Excel.Range
Dim myBRCell As Excel.Range
If Target Is Nothing Then
Set myTLCell = ipWs.Cells(1, 1)
Set myBRCell = ipWs.Cells(myCols, myRows)
Else
Set myTLCell = ipWs.Cells(1, Target.Cells.SpecialCells(xlCellTypeLastCell).Row + 2)
Set myBRCell = ipWs.Cells(myCols, Target.Cells.SpecialCells(xlCellTypeLastCell).Row + 2 + myRows)
End If
Set Target = ipWs.Range(myTLCell, myBRCell)
Target = GetTableArray(myTable)
Next
End Sub
Public Function GetTableArray(ByVal ipTable As Word.Table) As Variant
Dim myArray As Variant
Dim myRow As Long
Dim myCol As Long
ReDim myArray(1 To ipTable.Range.Tables.Item(1).Range.Rows.Count, 1 To ipTable.Range.Tables.Item(1).Range.Columns.Count)
For myRow = 1 To UBound(myArray, 1) - 1
For myCol = 1 To UBound(myArray, 2) - 1
Dim myText As String
myText = ipTable.Cell(myRow, myCol).Range.Text
myArray(myRow, myCol) = VBA.Left$(myText, Len(myText) - 2)
Next
Next
GetTableArray = myArray
End Function
Public Function TryGetFileList(ByRef opFileList As Variant) As Boolean
On Error Resume Next
opFileList = _
Application.GetOpenFilename _
( _
"Word files (*.doc; *.docx),*.doc;*.docx", _
2, _
"Browse for file containing table to be imported", _
, _
True _
)
TryGetFileList = (Err.Number = 0) And IsArray(opFileList)
On Error GoTo 0
End Function
Public Function TryGetWordDoc _
( _
ByVal ipName As String, _
ByRef ipWdApp As Word.Application, _
ByRef opDoc As Word.Document _
) As Boolean
On Error Resume Next
Set opDoc = ipWdApp.Documents.Open(ipName, ReadOnly:=True)
TryGetWordDoc = (Err.Number = 0) And (Not opDoc Is Nothing)
On Error GoTo 0
End Function
Public Function Report(ByVal ipString As String, ByVal ipError As ImportError)
Select Case ipError
Case NoTablesInDocument
MsgBox ipString & " Contains no tables", vbExclamation, "Import Word Table"
Case Else
End Select
End Function
For tableCounter ... Next code modified below to extract data directly rather than using copy and paste.
Sub ImportWordTablesArray()
Dim WordApp As Object
Dim WordDoc As Object
Dim arrFileList As Variant, Filename As Variant
Dim tableNo As Integer 'table number in Word
Dim iRow As Long 'row index in Excel
Dim iCol As Integer 'column index in Excel
Dim resultRow As Long
Dim tables() As Variant
Dim tableCounter As Long
On Error Resume Next
arrFileList = Application.GetOpenFilename("Word files (*.doc; *.docx),*.doc;*.docx", 2, _
"Browse for file containing table to be imported", , True)
If Not IsArray(arrFileList) Then Exit Sub '<-user cancelled import file browser
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
Worksheets("Test").Range("A:E").Clear '<-ClearContents to clear only text
For Each Filename In arrFileList
Set WordDoc = WordApp.Documents.Open(Filename, ReadOnly:=True)
With WordDoc
If WordDoc.ProtectionType <> wdNoProtection Then
WordDoc.Unprotect Password:=SREPedit
End If
tableNo = WordDoc.tables.Count
If tableNo = 0 Then
MsgBox WordDoc.Name & "Contains no tables", vbExclamation, "Import Word Table"
End If
tables = Array(1, 2, 8) '<- Select tables for data extraction
For tableCounter = LBound(tables) To UBound(tables)
With .tables(tables(tableCounter))
For iRow = 1 To .Rows.Count
For iCol = 1 To .Columns.Count
Cells(resultRow, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text)
Next iCol
resultRow = resultRow + 1
Next iRow
End With
resultRow = resultRow + 1
Next tableCounter
.Close False
End With
Next Filename
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub

Can't add rows to a Word table with vertically merged cells (VBA Excel Macro on Word Doc) [duplicate]

This is how the table looks like.
Code:
Sub WordTableTester()
Dim CurrentTable As table
Dim wdDoc As Document
Dim Rw As Long, col As Long
Dim wdFileName
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , "Please choose a file containing requirements to be imported")
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
With wdDoc
Set CurrentTable = wdDoc.Tables(1)
Rw = 9: col = CurrentTable.Columns.Count
wdDoc.Range(CurrentTable.Cell(Rw, 1).Range.start, _
CurrentTable.Cell(Rw, col).Range.start).Select
wdDoc.Application.Selection.InsertRowsBelow
End With
End Sub
When I run this, I get the an error message: Run-Time error '5941': The requested member of the collection does not exist.
Note: I'm running a VBA Excel Macro and importing/adding rows to a table in a Word Doc
Working with merged rows in MS Word Table is slightly tricky.
Is this what you want?
Sub Sample()
Dim CurrentTable As Table
Dim wdDoc As Document
Dim Rw As Long, col As Long
Set wdDoc = ActiveDocument '<~~ Created this for testing
Set CurrentTable = wdDoc.Tables(1)
Rw = 9: col = CurrentTable.Columns.Count
wdDoc.Range(CurrentTable.Cell(Rw, 1).Range.Start, _
CurrentTable.Cell(Rw, col).Range.Start).Select
wdDoc.Application.Selection.InsertRowsBelow
End Sub
ScreenShot
Edit
You table's format is all screwed up. Table was created with few rows and then the cells were merged/split to create new rows and hence you were getting the error. Also since you are automating word from excel, I would recommend the following way.
Try this
Sub WordTableTester()
Dim oWordApp As Object, oWordDoc As Object, CurrentTable As Object
Dim flName As Variant
Dim Rw As Long, col As Long
flName = Application.GetOpenFilename("Word files (*.docx),*.docx", _
, "Please choose a file containing requirements to be imported")
If flName = False Then Exit Sub
Set oWordApp = CreateObject("Word.Application")
oWordApp.Visible = True
Set oWordDoc = oWordApp.Documents.Open(flName)
Set CurrentTable = oWordDoc.Tables(1)
Rw = 7: col = CurrentTable.Columns.Count
oWordDoc.Range(CurrentTable.Cell(Rw, 1).Range.Start, _
CurrentTable.Cell(Rw, col).Range.Start).Select
oWordDoc.Application.Selection.InsertRowsBelow
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:

Paste charts from Excel to Word error - The Remote Server Machine does not exist (Error 462)

I have a macro which carries out the following logic in VBA in excel:
Opens a word document
Loop through all the pre set bookmarks in the document
When a bookmark is found, loop through all the chart objects in a specific sheet, when the Chart Name matches the bookmark name, copy that into the word doc
I am running into Error 462 on the second run of the macro. I realise it's to do with not referencing an object properly but I cant seem to find where the culprit is.
My code looks like this:
Sub buildDocument()
'#### Initialise our variables
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim theWorksheet As Worksheet
Dim Chart As ChartObject
Dim wdBookmarksArray() As Variant
Dim counter1 As Integer
Dim counter2 As Integer
Dim noCharts As Integer
Dim counter4 As Integer
Dim PasteObect As Variant
Dim quarter As String
Dim sheetsArr As String
'#### Switch off update ####
Application.ScreenUpdating = False
'#### Create a new word doc; minimise; ####
Set wdApp = New Word.Application
With wdApp
.Visible = True
.WindowState = wdWindowStateMinimize
End With
On Error GoTo ErrorHandler
'#### Build a dialog box to find the
' correct word template file ####
Set wdDoc = wdApp.Documents.Open(openDialog())
counter2 = 1
counter3 = 1
For counter1 = 1 To wdDoc.Bookmarks.Count
'#### Export "New Issue Timing" graphs to
' word document ####
Call copyGraphs(newIssuesTiming, _
counter1, _
wdDoc, _
wdApp)
Next
ThisWorkbook.sheets(mainSheet).Select
Set wdApp = Nothing
Set wdDoc = Nothing
Exit Sub
ErrorExit:
wdDoc.Close
wdApp.Quit
Set wdApp = Nothing
Set wdDoc = Nothing
Exit Sub
ErrorHandler:
Dim error_report As ErrorControl
Set error_report = New ErrorControl
error_report.SetErrorDetail = Err.Description
error_report.SetErrorNumber = Err.Number
error_report.SetErrorSection = "BUILD_WORD_DOC"
If error_report.GenerateErrorReport Then
Resume ErrorExit
End If
Set error_report = Nothing
My copyGraphs looks like:
Sub copyGraphs(sheet As String, _
counter1 As Integer, _
wdDoc As Word.Document, _
wdApp As Word.Application)
Dim wdBookmarksArray() As Variant
Dim counter2 As Integer
Dim Chart As ChartObject
Dim theWorksheet As Worksheet
Dim noCharts As Integer
Dim counter4 As Integer
Dim PasteObect As Variant
Dim quarter As String
Dim sheetsArr As String
For Each Chart In ThisWorkbook.sheets(sheet).ChartObjects
If wdDoc.Bookmarks(counter1).name = Chart.name Then
ThisWorkbook.sheets(sheet).ChartObjects(Chart.name).Copy
wdApp.Selection.Goto What:=wdGoToBookmark, name:=wdDoc.Bookmarks(counter1).name
wdApp.Selection.PasteSpecial DataType:=wdPasteEnhancedMetafile
End If
Next
End Sub
The copyGraph Sub is in the same module as the sub that calls it.
Adding ByVal did in fact work, but required the excel sheet to be closed and reopened to clear all the objects from memory.
Credit #R3uK for the answer
The below code works:
Sub buildDocument()
'#### Initialise our variables
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim theWorksheet As Worksheet
Dim Chart As ChartObject
Dim wdBookmarksArray() As Variant
Dim counter1 As Integer
Dim counter2 As Integer
Dim noCharts As Integer
Dim counter4 As Integer
Dim PasteObect As Variant
Dim quarter As String
Dim sheetsArr As String
'#### Switch off update ####
Application.ScreenUpdating = False
'#### Create a new word doc; minimise; ####
Set wdApp = New Word.Application
With wdApp
.Visible = True
.WindowState = wdWindowStateMinimize
End With
On Error GoTo ErrorHandler
'#### Build a dialog box to find the
' correct word template file ####
Set wdDoc = wdApp.Documents.Open(openDialog())
counter2 = 1
counter3 = 1
For counter1 = 1 To wdDoc.Bookmarks.Count
'#### Export "New Issue Timing" graphs to
' word document ####
Call copyGraphs(newIssuesTiming, _
counter1, _
wdDoc, _
wdApp)
Next
ThisWorkbook.sheets(mainSheet).Select
wdDoc.Save
wdDoc.Close
wdApp.Quit
Set wdApp = Nothing
Set wdDoc = Nothing
Exit Sub
ErrorExit:
wdDoc.Close
wdApp.Quit
Set wdApp = Nothing
Set wdDoc = Nothing
Exit Sub
ErrorHandler:
Dim error_report As ErrorControl
Set error_report = New ErrorControl
error_report.SetErrorDetail = Err.Description
error_report.SetErrorNumber = Err.Number
error_report.SetErrorSection = "BUILD_WORD_DOC"
If error_report.GenerateErrorReport Then
Resume ErrorExit
End If
Set error_report = Nothing
End Sub
Routine to copy graphs :
Sub copyGraphs(ByVal sheet As String, _
ByVal counter1 As Integer, _
ByVal wdDoc As Word.Document, _
ByVal wdApp As Word.Application)
Dim wdBookmarksArray() As Variant
Dim counter2 As Integer
Dim Chart As ChartObject
Dim theWorksheet As Worksheet
Dim noCharts As Integer
Dim counter4 As Integer
Dim PasteObect As Variant
Dim quarter As String
Dim sheetsArr As String
For Each Chart In ThisWorkbook.sheets(sheet).ChartObjects
If wdDoc.Bookmarks(counter1).name = Chart.name Then
ThisWorkbook.sheets(sheet).ChartObjects(Chart.name).Copy
ThisWorkbook.sheets(sheet).ChartObjects(Chart.name).Copy
wdApp.Selection.Goto What:=wdGoToBookmark, name:=wdDoc.Bookmarks(counter1).name
wdApp.Selection.PasteSpecial DataType:=wdPasteEnhancedMetafile
End If
Next
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.