将动态范围从excel复制到word vba

Question

我有一个数据表，范围每个星期都在变化，这意味着上次使用的行和上次使用的列会有所不同。 我希望一次复制3个范围，并使用vba将其作为图片粘贴到word中。 这是较大代码的一部分，所以这就是为什么我希望通过编写vba来实现它。

一次落后于3个范围的原因是因为图片大小最适合文字显示。 标头合并在第2行和第3行中。我向您显示4个范围，但有时我会得到2个范围，有时是6个范围。 即3个范围或以下范围应该只是一张图片，而4-6个范围将意味着我有2张图片。

现在，当我运行代码时，没有任何文字粘贴。

Sub Table()

    Dim wdapp As Word.Application
    Set wdapp = New Word.Application

    With wdapp
        .Visible = True
        .Activate
        .Documents.Add
    End With

    With ThisWorkbook.Worksheets("Table")
        Dim a, b, c, RR As Range
  '1
        Set a = .Cells.Find("Header1", LookIn:=xlValues)

        If Not a Is Nothing Then
            Dim firstAddress As String
            firstAddress = a.Address
            Do
' 2
  Set b = .Cells.Find("Header1", a, LookIn:=xlValues)
' 3
  Set c = .Cells.Find("Header1", b, LookIn:=xlValues)
'Union
Set RR = Union(Range(a.End(xlDown).End(xlDown), a.Resize(, 7)), Range(b.End(xlDown).End(xlDown), b.Resize(, 7)), Range(c.End(xlDown).End(xlDown), a.Resize(, 20)))
    RR.CopyPicture Appearance:=xlScreen, Format:=xlPicture
                wdapp.Selection.Paste
                Set a = .UsedRange.FindNext(a)
                If a Is Nothing Then Exit Do
            Loop While a.Address <> firstAddress


        End If
    End With

End Sub

Answer 1

这里有一些问题：

• 嵌套With s为常不错的计划，并似乎在这个例子中很随意
• Find不喜欢查找包含合并单元格一部分的行，因此最好只在整个工作表上使用查找
• 合并单元格中的.End(xlDown)只是选择下一个使用的单元格，而不是整个块，因此我们需要应用两次
• 如果d为Nothing ，则循环条件将产生错误，因为它仍然尝试检查其地址。 首先检查“ Nothing然后根据需要跳出循环

总而言之，我相信这应该可行：

Option Explicit

Sub Table()

    Dim wdapp As Word.Application
    Set wdapp = New Word.Application

    With wdapp
        .Visible = True
        .Activate
        .Documents.Add
    End With

    With ThisWorkbook.Worksheets("Table")
        Dim d As Range
        Set d = .Cells.Find("Header1", LookIn:=xlValues)
        If Not d Is Nothing Then
            Dim firstAddress As String
            firstAddress = d.Address
            Do
                .Range(d, d.End(xlDown).End(xlDown).End(xlToRight)).CopyPicture Appearance:=xlScreen, Format:=xlPicture
                wdapp.Selection.Paste
                Set d = .UsedRange.FindNext(d)
                If d Is Nothing Then Exit Do
            Loop While d.Address <> firstAddress
        End If
    End With

End Sub

对于要将前三个块粘贴为一张图片，而将第四个块粘贴为单独图片的特定情况，可以将do循环替换为：

    .Range(d, d.End(xlDown).End(xlDown).End(xlToRight).End(xlToRight).End(xlToRight).End(xlToRight).End(xlToRight)).CopyPicture Appearance:=xlScreen, Format:=xlPicture
    wdapp.Selection.Paste
    Dim i As Long
    For i = 1 To 3
        Set d = .UsedRange.FindNext(d)
    Next i
    .Range(d, d.End(xlDown).End(xlDown).End(xlToRight)).CopyPicture Appearance:=xlScreen, Format:=xlPicture
    wdapp.Selection.Paste

Answer 2

我刚刚更改了您的朦胧声明，因为这些声明不适用于2016年赢7

Dim wdapp As Object
Dim d As Range
Set wdapp = CreateObject("Word.Application")

然后就很好了。