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

Question

I have a sheet of data and the range vary each week meaning last used row and last used column vary. I hope to copy 3 ranges at a time and paste it as picture into word using vba. This is part of a larger codes so that is why I am hoping to achieve it by writing vba.

The reason behind 3 ranges at a time is because of the picture size fits best in word. Headers are merged in row 2 and 3. I am showing you 4 ranges but sometimes I get 2 ranges and sometimes 6 ranges. ie 3 ranges or below should just be one picture and from 4-6 ranges will mean I have 2 pictures in word.

Right now when I run my codes, nothing is pasted in word.

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

There are a few problems here:

• Nested With s are normally a bad plan, and seem to be quite haphazard in this example
• Find doesn't like looking in rows that contain part of merged cells, so it's best to just use find on the whole sheet
• .End(xlDown) from a merged cell just selects the next used cell beolw it, not the whole block, so we need to apply this twice
• Your loop condition will produce an error if d is Nothing , as it still tries to check its address. Check for Nothing first and break out of the loop if needed

All told, this should work I believe:

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

For the specific case of wanting to paste the first three blocks as one picture, and the fourth as a separate picture, you can replace the do loop with:

    .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

I just changed your dim statements, since those will not work with 2016 on win 7

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

Then it worked just fine.