特定の文字列を、その文字列が書かれたセルの、上6セル及び下5セルに、コピー・ペーストしたい。

実現したいこと

特定の文字列（例：「HighBlack」）が入ったセルの、上6行分、下5行分のセルの値を、
全て「HighBlack」にしたいです。
列は一つの列だけです。
動けば、現在のコードの書き方には、特に拘りません。

初歩的な質問で大変恐縮ですが、
よろしくお願いいたします。

発生している問題・エラーメッセージ

型が一致しません。

該当のソースコード

VBA
1Sub 六つに割り当て()
2    Dim c As Range, r As Range, myRange As Range
3    Range("B1:B100000").Select
4    Set c = ActiveSheet.Cells.Find(what:="HighBlack", LookIn:=xlValues, lookat:=xlWhole)
5    Set myRange = c
6    For Each r In ActiveSheet.UsedRange
7    If r = "HighBlack" Then
8        Cells(r, 2).Copy
9        Cells(r - 1, 2).PasteSpecial
10        Cells(r - 2, 2).PasteSpecial
11        Cells(r - 3, 2).PasteSpecial
12        Cells(r - 4, 2).PasteSpecial
13        Cells(r - 5, 2).PasteSpecial
14        Cells(r - 6, 2).PasteSpecial
15        Cells(r + 1, 2).PasteSpecial
16        Cells(r + 2, 2).PasteSpecial
17        Cells(r + 3, 2).PasteSpecial
18        Cells(r + 4, 2).PasteSpecial
19        Cells(r + 5, 2).PasteSpecial
20        Application.CutCopyMode = False
21    End If
22    Next r
23    myRange.Select
24End Sub

試したこと

ここに問題に対して試したことを記載してください。

補足情報（FW/ツールのバージョンなど）

ここにより詳細な情報を記載してください。

行動規範の内容に同意します

回答2件

Sub sample()
    Dim f As String, col As Range
    f = "HighBlack"
    Set col = Columns(2)
    
    Dim rng As Range, c As Range
    If WorksheetFunction.CountIf(col, f) = 0 Then Exit Sub
    Set rng = col.Rows(WorksheetFunction.Match(f, col, 0))
    
    For Each c In Intersect(col, ActiveSheet.UsedRange)
        If c.Value = f Then Set rng = Union(rng, c)
    Next
    For Each c In rng
        c.Offset(-6).Resize(12).Value = f
    Next
End Sub

投稿2022/07/21 04:54

jinoji

総合スコア4585

YYJP

2022/08/17 17:30

すみません、参考にしようと戻ってきて、ご回答頂いたいたのに今更気づきました。ありがとうございました。

行動規範の内容に同意します

ベストアンサー

Cells(r, 2).Copy の r はセル(Rangeオブジェクト)です。Cellsの引数は行番号, 列番号の数値になります。
数値にしなければならないところに、Rangeオブジェクトを置いてますのでエラーになります。

その他、意味を理解せずに適当にどこからか引っ張ってきた無意味なコードが散見されます。
一度基礎から学習するか、ひとつひとつのコードをヘルプ等で理解することをお勧めします。

これって簡単そうで意外と難しいですね。最初、ループで上から移動しながら"HighBlack"なら上下にコピーするコードにしたら、
次のセルの値が"HighBlack"に代わるのでそれ以降はすべてコピーすることになってしまいます。

対策はいろいろありますが、最初に対象セル範囲を配列に格納しておいて、そちらで一致するかをチェックするコードにしてみました。

vba
1Sub 六つに割り当て1()
2    Dim ary() As Variant
3    ary = Range("B7", Cells(Rows.Count, 2).End(xlUp)).Value '処理対象セル範囲を配列に
4    
5    Dim i As Long
6    For i = 1 To UBound(ary)
7        If ary(i, 1) = "HighBlack" Then
8            Cells(i, 2).Resize(6).Value = ary(i, 1) '上6行分に張り付け
9            Cells(i + 7, 2).Resize(5).Value = ary(i, 1) '下5行分に張り付け
10        End If
11    Next
12End Sub