复制从excel到word vba的dynamic范围

我有一张数据，每周的范围有所不同，这意味着上次使用的行和上次使用的列有所不同。 我希望一次复制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 s嵌套通常是一个不好的计划，在这个例子中似乎是相当随意的
• Find不喜欢查看包含部分合并单元格的行，所以最好在整个表格中使用查找
• .End(xlDown)从一个合并的单元格结束.End(xlDown)只是select下一个使用的单元格，而不是整个块，所以我们需要应用这个两次
• 如果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循环replace为：

  .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") 

然后，它工作得很好。