
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ベストアンサー
- 回答日時:
#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で確認してください
回答いただきありがとうございました。
「行の挿入や削除のループは、末行から逆にループするのが鉄則です」←大変参考になりました。
教えていただいたコードで行いたい事ができました。
誠にありがとうございました。
No.2
- 回答日時:
こんばんは。
詳しく見ていませんが、
For tgt = 2 To tgtmax
上から処理して、行が増えるとズレると思いますので、下から処理したら
どうでしょうか?
For tgt = tgtmax To 2 Step -1 で下から2行までの処理になるかと。
回答いただきありがとうございました。
「For tgt = tgtmax To 2 Step -1」という処理は思いつきませんでしたので、大変参考になりました。
No.1
- 回答日時:
こんばんは
流し読みで試していないのですけれど
行を挿入するような感じなので
For tgt = 2 To tgtmax は
For tgt = tgtmax To 2 Step -1 として下からループしてみてください
あと、Exit For は If ws1.Range("B" & tgt).Value = "両方" Then が
True だと 1度処理して ループを抜けてしまいますので
おそらく要りません。
なんか、結合セルも対象になっているような感じですが、良いかな?
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
このQ&Aを見た人はこんなQ&Aも見ています
-
みんなに挑戦してほしい「色彩検定」
これまで多くの方々が受検したが「色彩検定」。その目的や活用法は人それぞれ。今回は、色彩検定に影響を受けた男女3名にインタビュー。
-
1.8tの車が0.9tの停まった車に衝突し、飛ばされて17m先に落ちました。1.8tの車の速度は?
交通科学
-
Excel VBA 特定の列のセル
Visual Basic(VBA)
-
Excelのファイルエラーについて 今ファイルをさくせいしているのですが、 新規作成したファイルに添
Excel(エクセル)
-
4
試験本番に後ろの席の人がかなり頻繁にごほごほと咳をしていて試験に集中できないような時はどのような対応をすればよいですか?
大学・短大
-
5
エクセルの文字ぼけ
Excel(エクセル)
-
6
VBAの記述方法について教えていただけると幸いです。
Visual Basic(VBA)
-
7
別々にワークブック保存
Visual Basic(VBA)
-
8
エクセルって複雑な処理は避けた方が良くないですか?
Excel(エクセル)
-
9
Excel(csv)でのフィルター機能について教えてください。 ある2つのcsvがあったとします。
Excel(エクセル)
-
10
Excelにて、フッターにシートの合計を入力したいのですが、分からずコードをご教授願います
Visual Basic(VBA)
-
11
VBで画像から線で囲まれた場所を取得したい
Visual Basic(VBA)
-
12
Excel VBAのFunctionについて
Visual Basic(VBA)
-
13
助けてください! この処理を別のファイルのExcelファイルに転記したいです! sub 出来高 ()
Visual Basic(VBA)
-
14
VBAの質問です! 転記元のセルが結合の場合にはどうしらちゃんと転記されますでしょうか? d4とd5
Visual Basic(VBA)
-
15
エクセルVBAで教えて頂きたいのですが?
Visual Basic(VBA)
-
16
Excelで下記のようにマクロを作ったところ、一回目は実行できたのですが、二回目以降「実行時エラー1
Visual Basic(VBA)
-
17
excel2021で実行できないマクロ。どこを直したらいいのか
Visual Basic(VBA)
-
18
VBAで組み合わせ算出やCOUNTIFSの処理を高速化したいです。
Excel(エクセル)
-
19
VBAで教えて頂きたいのですが?
Visual Basic(VBA)
-
20
エクセル マクロでマクロ名が変わってしまってエラーになります
Excel(エクセル)
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
人気Q&Aランキング
-
4
Excel VBA、 別ブックの最終行...
-
5
EXCELで変数をペーストしたい
-
6
エクセル マクロで セルの範...
-
7
screenupdatingが機能しなくて...
-
8
Excel vbaで特定の文字以外が入...
-
9
任意フォルダから画像をすべて...
-
10
【EXCEL VBA】Range("A:A").Fi...
-
11
セル色なしの行一括削除
-
12
DataGridViewの各セル幅を自由...
-
13
【VBA ・ エクセル】 テキスト...
-
14
Excelのプルダウンで2列分の情...
-
15
クリックされたセルの位置を取...
-
16
excelで置換をしたいんですが
-
17
連続する複数のセル値がすべて0...
-
18
VBAでセルをクリックする回...
-
19
EXCELのVBA-フィルタ抽出後の...
-
20
Excelのハイパーリンクにマクロ...
おすすめ情報
公式facebook
公式twitter