ExcelVBAの転記について

現在、下記のコードを利用しています。

Sub aaaa()

Dim ws13 As Object
Dim ws15 As Object
Dim targetWord As String

Set ws13 = Worksheets("Sheet13")
Set ws15 = Worksheets("Sheet15")
maxrow = ws13.Cells(Rows.Count, "A").End(xlUp).Row
maxC = ws13.Cells(2, Columns.Count).End(xlToLeft).Column
maxR = ws15.Cells(Rows.Count, "A").End(xlUp).Row + 1
targetWord = ws15.Range("A1")

With ws13

i = 2

Do Until .Cells(i, 12) <> targetWord
.Range(.Cells(2, 2), .Cells(i, maxC - 1)).Copy
ws15.Cells(maxR, 2).PasteSpecial xlPasteAll, Transpose:=True
i = i + 1
Loop

For j = maxrow To 2 Step -1

If .Cells(j, 12) = targetWord Then
.Range(j & ":" & j).Delete
End If
Next j



End With

End Sub

特定のワードが無くなるまで、転記しています。

問題なく作動するのですが、
特定のワードが無くなるまでではなく、特定のワードの範囲を選択して、転記すると書き直したいのです。

同一グループを選択するというコードは、どのように記載するのでしょうか？
お手数をおかけしますが、ご教示をお願いします。

No.1 ベストアンサー 回答者： Qchan1962 回答日時： 2022/03/23 21:05

こんばんは

少しなさりたい事が分からないのですが、
.Range(.Cells(2, 2), .Cells(i, maxC - 1)).Copy
ws15.Cells(maxR, 2).PasteSpecial xlPasteAll, Transpose:=True
の部分を選択に変える場合は
With ws13
i = 2
Dim r As Range
Do Until .Cells(i, 12) <> targetWord
If r Is Nothing Then
Set r = .Range(.Cells(2, 2), .Cells(i, maxC - 1))
Else
Set r = Union(r, .Range(.Cells(2, 2), .Cells(i, maxC - 1)))
End If
'.Range(.Cells(2, 2), .Cells(i, maxC - 1)).Copy
'ws15.Cells(maxR, 2).PasteSpecial xlPasteAll, Transpose:=True
i = i + 1
Loop
.Activate
If Not r Is Nothing Then r.Select
'For j = maxrow To 2 Step -1
'If .Cells(j, 12) = targetWord Then
'.Range(j & ":" & j).Delete
'End If
'Next j
End With
こんな感じかな、、元もコードはコメントとして残しています
.Activateは違うシートで実行された場合のエラー回避

＞特定のワードの範囲を選択して
この場合は、どのような条件を考えられているのでしょう？
現在はキーワードが一致しなくなるまで上からループ

例えば、空白があるなど条件が設定できるのならループを抜ける条件に
加えれば良い事になります。

よくわからなかったので、選択する所だけコードサンプルにしてみました
コピーする時は　Selection.Copyで

この回答へのお礼

ありがとうございました。

お礼日時：2022/03/23 21:12