B列に特定の文字列が入っている時、その文字列を含む行を下に複製＆複製した方のA列の末尾に「A」を追加

B列に「両方」が入っている時、その「両方」を含む内容を下に複製し、複製した方のA列の末尾に「A」を追加したいです。

下記に示す内容のVBAを作成しましたが、添付する図のように内容が一か所しか複製されないのです。
どこを修正すれば良いでしょうか。

よろしくお願いいたします。


Sub 両方が入っている場合に下に複製()

Dim tgt As Long
Dim tgtmax As Long
Dim ws1 As Worksheet

Set ws1 = ThisWorkbook.Worksheets("Sheet1")
tgtmax = ws1.Cells(Rows.Count, "A").End(xlUp).Row 'tgtデータの最終行




'両方の場合の複製
For tgt = 2 To tgtmax

If ws1.Range("B" & tgt).Value = "両方" Then
Application.Goto Reference:=ws1.Range("A" & tgt), Scroll:=True

Application.ScreenUpdating = False

'// 現在行位置を取得
iRow = Selection.Row
'// 選択行数を取得
iRowCount = Selection.Rows.Count
If (iRowCount = 1) Then
iRowCount = 0
ElseIf (iRowCount > 1) Then
iRowCount = iRowCount - 2
End If

'// 選択セルの先頭行を選択
Range(iRow & ":" & iRow).Select

'// 選択行をコピー
Selection.Copy

'// 行数分だけ選択
Range(iRow + 1 & ":" & iRow + 1 + iRowCount).Select

'// 行数分貼り付け
Selection.Insert Shift:=xlDown
Range("A" & iRow + 1 + iRowCount).Select
Selection.Value = Selection.Value & "A" '複製した文字列の末尾に「A」を追加

Application.ScreenUpdating = True


Exit For
End If
Next


End Sub

No.3 ベストアンサー 回答者： Qchan1962 回答日時： 2022/02/22 21:28

＃１ですが

iRowCount = Selection.Rows.Count　が気になって考えてみましたが
添付図ではありませんが、、結合セルがあると言う事でしょうか・・
結合セルがある場合、
逆からループすると、どうも計算が合わないような気がします。

しかし、行の挿入や削除のループは、末行から逆にループするのが鉄則です
上から廻す場合は、一旦配列などに入れ出力する方法になります。（これが理想ですが）
.Selectなどを使用している所から、少し難しい事になりそうですね。

ご質問のコードを基に（基本的に.Selectなどをそのままでループもカウント変数を使う方法を維持）

対象セルの結合セルに対応したコードサンプルを検証してみてください
コメントを自身で書き加えると理解できると思います
結合セル在っても無くても大丈夫です

Sub 両方が入っている場合に下に複製()
Dim tgt As Long
Dim tgtmax As Long
Dim iRowCount As Long
Dim ws1 As Worksheet

　 Set ws1 = ThisWorkbook.Worksheets("Sheet1")
　 'tgtデータの最終行
　 tgtmax = ws1.Cells(Rows.Count, "A").End(xlUp).Row

　 Application.ScreenUpdating = False
　 '行末からループ
　 For tgt = tgtmax To 2 Step -1
　 '両方の場合の複製
　　 If ws1.Range("B" & tgt).Value = "両方" Then
　 '実験用ステップ実行でスクロールすると見にくいので Scroll:=False
　　　　Application.Goto Reference:=ws1.Range("A" & tgt), Scroll:=False
　 '選択セルを含む行　.EntireRow
　　　　Selection.EntireRow.Copy
　 '選択行数　通常：１結合時：結合行数
　　　　iRowCount = Selection.Rows.Count
　　　　Range(tgt + iRowCount & ":" & tgt + iRowCount).Insert Shift:=xlDown
　　　　Application.CutCopyMode = False　 'コピー範囲を消す
　 '変更　対象セルの１つ下に挿入　（結合時：結合行数）
　　　　Range("A" & tgt + iRowCount).Select
　 '複製した文字列の末尾に「A」を追加’変更 結合セルの値が表示されているセル　Selection(1)
　　　　Selection(1).Value = Selection(1).Value & "A"
　　 End If
　 Next
　 Application.ScreenUpdating = True
End Sub

このままだと読みにくいのでVBEで確認してください

この回答へのお礼

回答いただきありがとうございました。

「行の挿入や削除のループは、末行から逆にループするのが鉄則です」←大変参考になりました。
教えていただいたコードで行いたい事ができました。

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

お礼日時：2022/02/22 23:08

No.2 回答者： mygoonickname 回答日時： 2022/02/22 20:10

こんばんは。

詳しく見ていませんが、
For tgt = 2 To tgtmax
上から処理して、行が増えるとズレると思いますので、下から処理したら
どうでしょうか？

For tgt = tgtmax To 2 Step -1　で下から2行までの処理になるかと。

この回答へのお礼

回答いただきありがとうございました。

「For tgt = tgtmax To 2 Step -1」という処理は思いつきませんでしたので、大変参考になりました。

お礼日時：2022/02/22 23:05

No.1 回答者： Qchan1962 回答日時： 2022/02/22 20:08

こんばんは

流し読みで試していないのですけれど
行を挿入するような感じなので
For tgt = 2 To tgtmax　は　
For tgt = tgtmax To 2 Step -1　として下からループしてみてください
あと、Exit For　は　If ws1.Range("B" & tgt).Value = "両方" Then　が
True　だと　1度処理して　ループを抜けてしまいますので
おそらく要りません。
なんか、結合セルも対象になっているような感じですが、良いかな？