使用VBA将分离的单元格从Excel表复制到Word表 [英] Copy Disjointed Cells from Excel Table to Word Table Using VBA

问题描述

我正在尝试将脱节的单元格从excel文档复制到word中的光标位置，并使用我的预定义表格样式.

I'm trying to copy disjointed cells from an excel document to the cursor location in word and use my predefined table style.

当我仅复制并粘贴到当前活动工作表中时，不相交的复制/粘贴在excel中效果很好，但是当我尝试从word执行相同的复制/粘贴时，它最终会从顶部复制整个表，一直到右下角，而不是进行脱节的复制/粘贴.

The disjoint copy/paste works nicely in excel when I just copy and paste into the current active worksheet, but as soon as I try to execute the same copy/paste from word, it ends up copying the entire table from top-left all the way to bottom-right, instead of doing the disjointed copy/paste.

我知道从excel VBA到word VBA的各个函数之间存在一些差异，但是我认为可以通过在调用函数时指定库来解决此问题.

I know there are some differences between the individual function from excel VBA to word VBA, but I thought it's possible to get around that by specifying the library when calling functions.

下面看到的是成功的脱节副本:

Seen below is a successful disjointed copy:

成功的脱节副本

这是有效的excel代码，已对其长度进行了编辑.

Here is the functioning excel code, edited for length.

if Copy3中的代码是有趣的部分:

The code within if Copy3 is the interesting part:

Sub GrabExcelTables()

' !Initializing everything

Dim phasesArray As Variant
phasesArray = Array("Scoping", "Umsetzung (Dev)", "Go Live")

With wsFrom

    'Copy schema for tables 1 and 2
    ' !Omitted for length

    'Copy schema for tables 3 and 4
    ' !Omitted for length

    'Copy schema for tables 5 and 6
    If Copy3 Then

        'Iterate through all columns to find which ones are filled
        For colCounter = Left + 1 To Right - 1
            If .Cells(22, colCounter).Value <> "-" Then
                wantedColumn.Add colCounter
            End If
        Next colCounter

        'Initialize RangeToCopy with top left cell of table
        Set RangeToCopy = .Cells(22, Left)

        'Iterate through all rows
        For rowCounter = 22 To 29

            'Only check those rows desired i.e.  part of phasesArray
            If (IsInArray(.Cells(rowCounter, Left).Value, phasesArray) Or rowCounter = 22 Or rowCounter = 29) Then

                'Union row phase header
                Set RangeToCopy = Union(RangeToCopy, .Cells(rowCounter, Left))

                'Add all columns within row that were selected as filled earlier
                For Each col In wantedColumn
                    Set RangeToCopy = Union(RangeToCopy, .Cells(rowCounter, col))
                Next col

                'Union final total column
                Set RangeToCopy = Union(RangeToCopy, .Cells(rowCounter, Right))
            End If
        Next rowCounter
    End If

    'Copy schema for table 7
    ' !Omitted for length

    'Copy range
    RangeToCopy.Copy
    .Range("A42").PasteSpecial Paste:=xlValues

End With



Set RangeToCopy = Nothing



End Sub

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
  IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function

现在除了修改VBA单词外，几乎相同的代码，再次对其长度进行了

Now pretty much the same code except adapted to word VBA, again edited for length:

Sub GrabExcelTables()

' !Initializing everything

Dim phasesArray As Variant
phasesArray = Array("Scoping", "Umsetzung (Dev)", "Go Live")


'specify the workbook to work on
WorkbookToWorkOn = ActiveDocument.Path & "\Kalkulationssheet_edit.xlsx"


Set oXL = CreateObject("Excel.Application")

On Error GoTo Err_Handler

'Open the workbook
Set oWB = Workbooks.Open(FileName:=WorkbookToWorkOn)

Set wsFrom = oWB.Sheets(7)

' !Initializing everything

With wsFrom

    'Copy schema for tables 1 and 2
    ' !Omitted for length

    'Copy schema for tables 3 and 4
    ' !Omitted for length

    'Copy schema for tables 5 and 6
    If Copy3 Then

        'Iterate through all columns to find which ones are filled
        For colCounter = Left + 1 To Right - 1
            If .Cells(22, colCounter).Value <> "-" Then
                wantedColumn.Add colCounter

                'MsgBox "Wanted Column: " & colCounter

            End If
        Next colCounter

        'Initialize RangeToCopy with top left cell of table
        Set RangeToCopy = .Cells(22, Left)

        'Iterate through all rows
        For rowCounter = 22 To 29

            'Only check those rows desired i.e.  part of phasesArray
            If (IsInArray(.Cells(rowCounter, Left).Value, phasesArray) Or rowCounter = 22 Or rowCounter = 29) Then

                'MsgBox "rowCounter: " & rowCounter & "cell value: " & .Cells(rowCounter, Left).Value

                'Union row phase header
                Set RangeToCopy = Excel.Union(RangeToCopy, .Cells(rowCounter, Left))

                'Add all columns within row that were selected as filled earlier
                For Each col In wantedColumn
                    Set RangeToCopy = Excel.Union(RangeToCopy, .Cells(rowCounter, col))
                Next col

                'Union final total column
                Set RangeToCopy = Excel.Union(RangeToCopy, .Cells(rowCounter, Right))
            End If
        Next rowCounter

    End If

    'Copy schema for table 7
    ' !Omitted for length

    'Copy range
    'MsgBox RangeToCopy.Text
    'MsgBox RangeToCopy.Value
    RangeToCopy.Copy
    '.Range("A42").PasteSpecial Paste:=xlValues

End With

'MsgBox Range.Text
Selection.PasteExcelTable False, True, False
'Selection.PasteSpecial DataType:=wdPasteRTF
Selection.MoveUp Unit:=wdLine, count:=11
Selection.MoveDown Unit:=wdLine, count:=1
ActiveWindow.View.ShowXMLMarkup = wdToggle
ActiveDocument.ToggleFormsDesign
Selection.Tables(1).Style = "StandardAngebotTable"


'Release object references
oWB.Close SaveChanges:=True
Set oWB = Nothing

Set RangeToCopy = Nothing

oXL.Quit
Set oXL = Nothing

'quit
Exit Sub

' Error Handler

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
  IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function

更改表格样式并将其粘贴到正确的位置完全可以按预期工作，但是将Excel中完全相同的代码与Excel库调用一起使用不能正常工作.

The changing of table style and pasting into the correct position works exactly as expected, but using the exact same code from excel with Excel library calls doesn't function as expected.

我总是复制整个表格，或更确切地说是从最左上角的单元格到最右下角的单元格，而不是获得完整的副本/粘贴.

Instead of getting a nice disjointed copy/paste, I always copy past the entire table, or more specifically a rectangle from the top-left most cell to the bottom-right most cell.

有人知道强制Word vba使用excel中相同的复制/粘贴命令的方法吗?我的另一个想法是只为表格单元格填充表格单元格，但是这将需要大量的代码重组，并且如果我不需要这样做的话会很好.感谢您的帮助！

Does anyone know a way to force word vba to use the same copy/paste commands from excel? The other idea I had was to just fill the table cell for cell, but that would require quite a bit of code restructuring and would be nice if I didn't need to do that. Thanks for the help!

推荐答案

我个人会尝试使用
Selection.PasteSpecial DataType:=wdPasteHTML
或
Selection.PasteSpecial DataType:=wdPasteOLEObject
代替
Selection.PasteExcelTable False, True, False

Personally, I'd try using
Selection.PasteSpecial DataType:=wdPasteHTML
or
Selection.PasteSpecial DataType:=wdPasteOLEObject
instead of
Selection.PasteExcelTable False, True, False

如果这不是您所期望的，那么这里是该Enum的其他成员:

If this one isn't what you expect, here are the other members of that Enum :

这篇关于使用VBA将分离的单元格从Excel表复制到Word表的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！