社会人&学生におすすめする色彩検定の勉強術

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

「B列に特定の文字列が入っている時、その文」の質問画像
教えて!goo グレード

A 回答 (3件)

#1ですが


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
  '選択行数 通常:1結合時:結合行数
    iRowCount = Selection.Rows.Count
    Range(tgt + iRowCount & ":" & tgt + iRowCount).Insert Shift:=xlDown
    Application.CutCopyMode = False  'コピー範囲を消す
  '変更 対象セルの1つ下に挿入 (結合時:結合行数)
    Range("A" & tgt + iRowCount).Select
  '複製した文字列の末尾に「A」を追加’変更 結合セルの値が表示されているセル Selection(1)
    Selection(1).Value = Selection(1).Value & "A"
   End If
  Next
  Application.ScreenUpdating = True
End Sub

このままだと読みにくいのでVBEで確認してください
    • good
    • 0
この回答へのお礼

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

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

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

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

こんばんは。



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

For tgt = tgtmax To 2 Step -1 で下から2行までの処理になるかと。
    • good
    • 0
この回答へのお礼

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

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

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

こんばんは


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

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

教えて!goo グレード

このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング