將動態范圍從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")

然后就很好了。