配列に入れた行を別シートに貼り付け

Question

Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng As Range
Dim adr As String
Dim arr() As Long
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
Set rng = ws2.Columns(2).Find("100")
If rng Is Nothing Then
MsgBox "見つかりませんでした。"
Exit Sub
Else
adr = rng.Address
ReDim arr(1)
arr(1) = rng.Row
End If

Do
Set rng = ws2.Columns(2).FindNext(After:=rng)
If rng.Address = adr Then
Exit Do
Else
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr)) = rng.Row
End If
Loop

End Sub

ネットから拾ったこコードを変えてsheet2のB列にある100という文字を見つけて配列に入れています
配列に入れた行をSheet1の二行目から行を挿入しながら貼り付けたいのですが教えていただけませんか
その時に2列目は貼り付けないようにしたいです（1列目と3から5列目を貼り付けたい）

Comments

[mattuwan]

>配列に入れた行をSheet1の二行目から行を挿入しながら貼り付けたい
すでにシート上に値があるが、１行目の直下に複数の検索結果を挿入したいということですか？

>その時に2列目は貼り付けないようにしたいです
空欄でいいということですか？
とりあえず貼りついても後で、クリアしてもいいのですか？

[yosida11]

その通りで1行目の直下に貼り付けたいです。

空白ではなく3列目を2列目に移動させたいです(他の列も一列づつ左に移動させたい)

Answer 1

こんな感じでどうでしょうか。

    Dim r, i
    r = 2
    For i = 1 To UBound(arr)
        With ws2.Rows(arr(i))
            ws1.Rows(r).Insert
            Union(.Columns("A:A"), .Columns("C:E")).Copy ws1.Cells(r, 1)
            r = r + 1
        End With
    Next

---

こうすると多少速いかも。

    Dim u As Range, i As Long
    Set u = ws2.Rows(arr(1))
    
    For i = 1 To UBound(arr)
        Set u = Union(u, ws2.Rows(arr(i)))
    Next
    
    ws1.Rows(2).Resize(UBound(arr)).Insert
    Union(u.Columns("A:A"), u.Columns("C:E")).Copy ws1.Cells(2, 1)

Comments

[yosida11]

ありがとうございます
試してみた結果思い通りに動きました
ただデータの量が多く少し時間が掛かってしまいました

[yosida11]

返信遅くなりすみません
とても早くなりました驚きました！
ありがとうございます。

Answer 2

1）sheet1の表から、オートフィルターで抽出
2）表の必要な範囲をコピー
3）SHeet2に挿入して貼り付け

という手順をマクロ化してみてはいかがでしょうか？

Comments

[yosida11]

ありがとうございます。
その方法なら、ややこしくなく私でも出来るかもしれないです。
実践してみます。