Copy range in Word avoiding clipboard

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

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

Answer 2

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