【部分一致した行を含む8行をシートにコピーする方法】 以下のような作業を行いたいのですが、どなたがコ

【部分一致した行を含む8行をシートにコピーする方法】
以下のような作業を行いたいのですが、どなたがコードをご提示いただけませんでしょうか？
シートＡ・・・集計
シートＢ・・・一覧 （同一ブック内）
シートBのA列にはコードが並んでいます。
この値を検索し、一致した場合、その行を含む8行をコピーしシートBへ貼り付けたい。よろしくお願いします！

質問者からの補足コメント

• お示し頂いたコードで完璧に動きました。しかし実務ベースでためしてみたところ、部分的にデータの繁栄ができませんでした。補足事項となりますが、実務ではA列のコード間隔は400行置きにあり、行の項目は55あります。コードの下記部分を書き換えてみたのですが未熟で理解不能なため上手くいきません？コード100001非表示、100002正常、100003部分異常な状態です。修正箇所をお示しいただけると助かります。よろしくお願いします。
  
  If Not f Is Nothing Then _
  c.Offset(, 1).Resize(400, 55).Value = f.Offset(, 1).Resize(400, 55).Value
  Next c
  End Sub

  
    補足日時：2022/08/30 18:56

• 補足の画像を間違えました。すいません

  
    補足日時：2022/08/30 19:04

No.1 ベストアンサー 回答者： fujillin 回答日時： 2022/08/30 16:54

こんにちは

一覧シートのA列には、5行目を最初として、必ず8行以上開けてコードが記入されているものと仮定してもよいものとしました。
（8行以下の場合は、重複して上書きされる可能性があります）
また、コード以外のセルは全て空白であるものとします。
コピーはB:K列の範囲で、値のみで良いものと解釈。
（書式等はコピーされません）


Sub Q13120140()
Dim sA As Worksheet, sB As Worksheet
Dim c As Range, f As Range

Set sA = Worksheets("集計")
Set sB = Worksheets("一覧")

sB.Columns(2).Resize(, 10).ClearContents
For Each c In sB.Columns(1).SpecialCells(xlCellTypeConstants)
Set f = sA.Columns(1).Find(c.Value)
If Not f Is Nothing Then _
c.Offset(, 1).Resize(8, 10).Value = f.Offset(, 1).Resize(8, 10).Value
Next c
End Sub

この回答へのお礼

ありがとうございます♪

お礼日時：2022/08/30 18:26