Word中的复制范围避免剪贴板

Question

我有下面的代码将 Word 中的一组表格复制到 Excel。正在复制的数据量会导致内存问题，所以我想避免使用剪贴板 - 即避免使用Range.Copy

Word 不支持Range.Value，我无法让Range(x) = Range(y) 工作。

对于避免剪贴板的方法有什么建议吗？文字格式可能会被垃圾。

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

您可能需要调整下面的代码以使其完全符合您的要求（Excel 不是我经常使用的东西），因为范围的计算有点不稳定，但它会将文本从 word 传输到 excel 而无需剪切并粘贴

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 代码修改为直接提取数据，而不是使用复制和粘贴。

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