エクセルから単語vbaへのダイナミックレンジのコピー

Question

データシートがあり、その範囲は毎週変わります。最後に使用された行と最後に使用されたカラムが異なることを意味します。私は一度に3つの範囲をコピーし、絵としてVBAを使って単語に貼り付けたいと思っています。これは大きなコードの一部ですので、私はvbaを書くことでそれを達成したいと考えています。

一度に3つの範囲の背後にある理由は、画像のサイズが単語に最も適しているためです。ヘッダは2行目と3行目にマージされます。私は4つの範囲を示していますが、時には2つの範囲と時には6つの範囲を取得します。すなわち3つの範囲またはそれ以下は1つの画像でなければならず、4から6の範囲は2つの画像を1つの単語として有することを意味する。

今すぐコードを実行すると、単語には何も貼り付けられません。

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は、その一部を含む行で見て好きではない。この例では、かなり行き当たりばったりのように見えるが、マージされたセル、それは、ちょうどそれbeolw次使用するセルを選択しただけで、マージされたセルからシート全体に見つける
• .End(xlDown)を使用するようにブロック全体最善ではありませんので、我々はこの二回
• あなたのループコンディを適用する必要がありますdがNothingの場合は、アドレスの確認を試みるため、エラーが発生します。最初Nothingをチェックし、すべてのは、私は信じている、これは動作するはずです、言われ

を必要に応じてループから抜け出す：1枚の画像として最初の三つのブロックを貼り付けたいの特定の場合については

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 

、 4番目は別の画像として、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

私はちょうどそれらが勝利7

に2016年に

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

を動作しませんので、それがうまく働いていた、あなたの薄暗い文を変更しました。