Copy range in Word avoiding clipboard - vba

Question

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

Answer 1

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

Answer 2

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