Question

我有一张数据，每周的范围不同，这意味着上次使用的行和最后使用的列有所不同。我希望一次复制3个范围，并使用vba将其粘贴为图片。这是更大代码的一部分，因此我希望通过编写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通常是一个糟糕的计划，在这个例子中似乎是非常随意的
Find不喜欢查看包含部分合并单元格的行，因此最好只在整张表上使用find
.End(xlDown)只选择下一个使用过的单元格beolw它，而不是整个块，所以我们需要应用这两次
如果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")

然后它运作得很好。

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

2 个答案: