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

Question

我有一张数据，每周的范围都不同，这意味着上一次使用的行和最后一次使用的列有所不同。我希望一次复制3个范围，并将其作为图片粘贴到word中，使用vba。这是一个更大的代码的一部分，所以我希望通过编写vba来实现它。

一次三个范围的原因是因为图片大小最适合于文字。标题合并在第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通常是一个糟糕的计划，在本例中似乎是相当随意的。
• Find不喜欢查看包含部分合并单元格的行，所以最好在整个工作表上使用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年的win 7不起作用

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

然后一切都很顺利。