マクロ、セルの値から行挿入して転記する方法

質問

エクセル2013です。
セルA1に
1,8,9,15
セルA2に
7,12
セルA3に
20,14,28
と入力されているとします。

For～Nextで回して
セルA1のカンマの数を
InStr関数で数えて
カンマが3個だから
その3を変数に入れて
それを利用して
A2から3行行挿入します。
で
カンマで区切られた順に
A1には1
A2には8
A3には9
A4には15
と転記させる
カンマは消してしまう

で、この時点で
元々セルA2だった所は
セルA5になっていて
7,12
が入力されているはずです。

で同じくそこを見させて
カンマが1個だから
A5の下に1行挿入したうえで
A5に7
A6に12
と転記
カンマは消す。

すると元々セルA3だった所は
セルA7になっていて
そこには20,14,28が入力されているはず
ここも同じように処理し
下の列へ進めて行く。

カンマが無いセルは
行挿入せず
この処理はしないで
A列のデータが有る最終行まで
繰り返す。

と
いうマクロを作成したいのですが
どういう方法で行えばいいか
うまく思いつきません。

配列は苦手でなのですが
配列を使わないと無理でしょうか？
どうかよろしくお願いします。

回答No.11

f272 · ベストアンサー

#1 & #6 です。
> すべての行が元々1行名のA1～E1になってしまいます。

これに関しては申し訳ない。改造しておきました。

> そういう意味では全列挿入の方がよかったのかな？です。

これに関しても，そのように改造しておきました。

Sub Sample()
Set key = Range("F1") 'カンマの入ったデータ列の最初の行
Set Rng = Range("A1:E1") '同時に行挿入する列の最初の行
Do
If key.Value = "" Then Exit Do 'keyが空白ならループ脱出
i = InStr(key, ",") 'keyの最初のカンマの位置を調べる
If i <> 0 Then 'keyの中にカンマの位置が見つかれば
key.Offset(1).EntireRow.Insert Shift:=xlDown 'keyのセルの1行下に空白行を挿入
kv = key.Value 'keyの値をいったん覚えて
key.Value = Left(kv, i - 1) 'keyの値のi-1文字目までをkeyのセルに入れる
Set key = key.Offset(1) 'keyを1行下に変更して
key.Value = Right(kv, Len(kv) - i) '元のkeyの値のi+1文字目から最後までを新しいkeyのセルに入れる
Rng.Copy Rng.Offset(1) 'rngのセルの内容を1行下にコピー
Set Rng = Rng.Offset(1) 'rngを1行下に変更
Else 'keyの中にカンマの位置が見つからなければ
Set key = key.Offset(1) 'keyを1行下に変更
Set Rng = Rng.Offset(1) 'rngを1行下に変更
End If
Loop
Application.CutCopyMode = False
End Sub

お礼

ありがとうございます。

手作業と同じイメージで動作します。
また、中身も解読できました。
これなら、私の能力でも多少の改造もできそうですし、
他へ流用も可能そうです。

処理したいエクセルファイルによって違いますが、
データは１00～300行でして、
F列の値がカンマ無しの1個だけの行が少なければいいのですが
カンマが有る行の多さと、セル内のカンマの数（50個もある場合が）
の多さもにも左右され、処理が終わると最終的な行数は、何十倍にもなります。

これを約100ファイルやらなければいけません。
平行で手作業でやってもらっていますが、拉致が空きません。

このコードで、一気に作業が加速すると思います。

ご丁寧に説明していただき、ありがとうございました。

回答No.14

kkkkkm

> カンマが有る行の多さ、セル内のカンマの数（50個もある場合が）
> の多さもにも左右され、処理が終わると最終的な行数は、何十倍にもなります。

画面の描画を止めて多少でもスピードアップをはかったほうが良さそうですね。

コピー貼り付けをせずに直接代入して実行中の画面描画も止めてみたものです。

Sub Test2()
Dim i As Long, j As Long
Dim n As Long, Count As Long
Dim mStr As String
Dim 処理行 As Long, 選択行 As Long

Application.ScreenUpdating = False

For i = Cells(Rows.Count, 6).End(xlUp).Row To 1 Step -1
mStr = Cells(i, "F").Value
Count = 0: n = 0
Do
n = InStr(n + 1, mStr, ",")
If n = 0 Then
Exit Do
Else
Count = Count + 1
End If
Loop
If Count > 0 Then
処理行 = i
Range(Cells(i, 1), Cells(i + Count - 1, 1)).EntireRow.Insert
選択行 = 処理行 + Count
mStr = mStr & ","
For j = 1 To Count + 1
処理行 = i + j - 1
Range(Cells(処理行, 1), Cells(処理行, 5)).Value = Range(Cells(選択行, 1), Cells(選択行, 5)).Value
Cells(処理行, 6).Value = Left(mStr, InStr(mStr, ",") - 1)
mStr = Mid(mStr, InStr(mStr, ",") + 1)
Next j
End If
Next i

Application.ScreenUpdating = True

End Sub

お礼

ご丁寧にありがとうございます。
直接代入の方が這う藍野は理解しているのですが
自分で構文が作れないので、なかなか難しいです。

回答No.13

kkkkkm

No12の説明が違ってました。
> 上記だと貼り付け位置が毎回同じで最初と最後だけデータがセルに代入される
> だけだと思います

じゃなくて処理行だけに貼り付けているですね。

コピー貼り付けでも場所を変更したら動作もそれほど遅くなくうまくいきます。
選択行 = 処理行 + Count
(場所はFor j = 1 To Count + 1のループの外でいいと思います)
はもとのままで
Next j
の後に
Range(Cells(選択行, 1), Cells(選択行, 5)).Copy
Range(Cells(処理行, 1), Cells(選択行 - 1, 5)).PasteSpecial
Application.CutCopyMode = False

で一度に空白セルにに貼り付けます。

お礼

ご丁寧にありがとうございます。
ファイルによって違いますが、データは１00～300行でして、
F列の値がカンマ無しの1個だけの行が少なければいいのですが
カンマが有る行の多さ、セル内のカンマの数（50個もある場合が）
の多さもにも左右され、処理が終わると最終的な行数は、何十倍にもなります。
それだけコピペの回数が多くなります。
でそのエクセルファイルを100ファイルくらい、やらなければいけないので
コピペは回避した方がいいかなと、思っています。

回答No.12

kkkkkm

> n = InStr(n + 1, mStr, ",")
> ↑ここでnに2が入り、これは、カンマで区切った値が2個？
> という意味でしょうか？　

InStrは第3引数で指定した文字(この場合カンマです)が第1引数の指定文字数から数えて何番目に登場したかを返します。
ですので、F列に8,9と有る場合は2番目(最初なのでn+1が1になっています)になります。たまたま値の数と同じ結果なので勘違いしたのだと思います。

> n = InStr(n + 1, mStr, ",")
> ↑ここでnに0が入るのですが、ここがわからないです。

2回目の時はn+1は3になりますので文字列8,9の3番目からカンマを探しても見つからないので0が返ります。

> Count = Count + 1←初期値の0が+1されてCountが１になり

ここが一回しか実行されないので結果カンマの数は1個とわかります。

> Range(Cells(選択行, 1), Cells(選択行, 5)).Copy
> Range(Cells(処理行, 1), Cells(処理行, 5)).PasteSpecial

上記だと貼り付け位置が毎回同じで最初と最後だけデータがセルに代入されるだけだと思います。

For j = 1 To Count + 1
で一行ずつ下にセルの指定を下げていってますので

Range(Cells(選択行, 1), Cells(選択行, 5)).Copy
Range(Cells(処理行 + j - 1, 1), Cells(処理行, 5)).PasteSpecial

とすればうまくいくと思いますが、コピー貼り付けはやめた方がいいです。時間がかかるのと連続してやるとエラーになることがあります。
選択行　＝　処理行+Countは選択行 = 処理行 + j - 1にして

For j = 1 To Count + 1
中略
選択行 = 処理行 + j - 1
Range(Cells(処理行, 1), Cells(処理行, 5)).Value = Range(Cells(選択行, 1), Cells(選択行, 5)).Value

でいいのではないでしょうか。

お礼

ご丁寧にありがとうございます。

nの件、他の方のコードも見ていたら
理解できました。
その上でkkkkkmの解説を読んで確信しました。

貼付けの件もです。
行を挿入していくと当たり前ですが
いろいろずれるんですね。
ウィンドで見ていても、処理している行や
対象の行やセルも動いてしまい
そこで混乱しわからなくなりました。
マクロ未使用の手作業では行が挿入されても混乱ないのですが。

＞コピー貼り付けはやめた方がいいです。

そうでした。もう忘れてました。
エクセルのコピペを使うのではなく
せっかくマクロを使用するのでPCのメモリに格納して
転記（代入？）の方が効率がいいのでしたね。

過去自分で作成した他のマクロはみなそうしてあったのですが
行挿入で混乱し、コピペでやろうと思ってしまいました。

補足

お礼時に失礼が有りました。
>その上でkkkkkmの解説を読んで確信しました。
↓
その上でkkkkkmさんの解説を読んで確信しました。

さんを付け忘れてました。
あわてていて、申し訳ありませんでした。

回答No.10

kkkkkm

配列使うやつです。

Sub Test()
Dim mStr As Variant
Dim i As Long, j As Long

For i = Cells(Rows.Count, "F").End(xlUp).Row To 1 Step -1
mStr = Split(Cells(i, "F"), ",")
If UBound(mStr) > 0 Then
Range(Cells(i, "A"), Cells(i + UBound(mStr) - 1, "A")).EntireRow.Insert
For j = LBound(mStr) To UBound(mStr)
Cells(i + j, "A").Value = Cells(i + UBound(mStr), "A").Value
Cells(i + j, "B").Value = Cells(i + UBound(mStr), "B").Value
Cells(i + j, "C").Value = Cells(i + UBound(mStr), "C").Value
Cells(i + j, "D").Value = Cells(i + UBound(mStr), "D").Value
Cells(i + j, "E").Value = Cells(i + UBound(mStr), "E").Value
'上の5行は下の一行でできます
'Cells(i + j, "A").Resize(1, 5).Value = Cells(i + UBound(mStr), "A").Resize(1, 5).Value
Cells(i + j, "F").Value = mStr(j)
Next j
End If
Next i
End Sub

お礼

ご丁寧にありがとうございます。

配列は、難しいですね。

f8で見ていくと、動きは理解できるのですが
このコードを最初から作成となると
全く無理です。

内容を理解していないと
あとで、改造、他へ流用が出来ないので
完全に解読できないと導入が厳しいです。

配列が使えると本当にいいのですが。

ネット検索で得た知識だけでは、とても作成できません。

回答No.9

kkkkkm

AからE列は挿入された行に元のデータを代入するということでしたら。

Sub Test2()
Dim i As Long, j As Long
Dim n As Long, Count As Long
Dim mStr As String, buf As String

For i = Cells(Rows.Count, "F").End(xlUp).Row To 1 Step -1
mStr = Cells(i, "F").Value
Count = 0: n = 0
Do
n = InStr(n + 1, mStr, ",")
If n = 0 Then
Exit Do
Else
Count = Count + 1
End If
Loop
If Count > 0 Then
Range(Cells(i, "A"), Cells(i + Count - 1, "A")).EntireRow.Insert
mStr = mStr & ","
For j = 1 To Count + 1
Cells(i + j - 1, "A").Value = Cells(i + Count, "A").Value
Cells(i + j - 1, "B").Value = Cells(i + Count, "B").Value
Cells(i + j - 1, "C").Value = Cells(i + Count, "C").Value
Cells(i + j - 1, "D").Value = Cells(i + Count, "D").Value
Cells(i + j - 1, "E").Value = Cells(i + Count, "E").Value
'上の5行は下の一行でできます
'Cells(i + j - 1, "A").Resize(1, 5).Value = Cells(i + Count, "A").Resize(1, 5).Value
Cells(i + j - 1, "F").Value = Left(mStr, InStr(mStr, ",") - 1)
mStr = Mid(mStr, InStr(mStr, ",") + 1)
Next j
End If
Next i
End Sub

お礼

ご丁寧にありがとうございます。

Cells(i + j - 1, "A").Value = Cells(i + Count, "A").Value
Cells(i + j - 1, "B").Value = Cells(i + Count, "B").Value
Cells(i + j - 1, "C").Value = Cells(i + Count, "C").Value
Cells(i + j - 1, "D").Value = Cells(i + Count, "D").Value
Cells(i + j - 1, "E").Value = Cells(i + Count, "E").Value
'上の5行は下の一行でできます
'Cells(i + j - 1, "A").Resize(1, 5).Value = Cells(i + Count, "A").Resize(1, 5).Value

こういう1行化がまだ私の能力では難しんですね。
すらっと出来るようになれるといいのですが。

回答No.8

nishi6

解決しているかどうかよくわからないので追記しておきます。
補足にある手順通りで、上から下に向かって処理しています。

Sub insertRow3()
　Dim rw As Long　　　　'// 全体の行カウンタ
　Dim rwWk As Long　　　'// 挿入する行数
　Dim rwIns As Long　　 '// 挿入する行カウンタ
　Dim rwDt As String　　'// カンマを含んだ値
　Dim kPot As Integer　 '// カンマの位置

　rw = 0
　With ActiveSheet.Range("A1")
　　While .Offset(rw, 0) <> ""
　　　'// カンマの数を計算
　　　rwDt = .Offset(rw, 5).Value　'// F列
　　　rwWk = Len(rwDt) - Len(Application.Substitute(rwDt, ",", ""))
　　　'// 必要行数を挿入
　　　Range("A" & rw + 2, "F" & rw + rwWk + 1). _
　　　　　　Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
　　　'// コピー
　　　Range("A" & rw + 1 & ":F" & rw + 1).Copy _
　　　　　　Range("A" & rw + 2 & ":A" & rw + rwWk + 1)
　　　'// 各数字を書き込む
　　　rwDt = rwDt & ","
　　　For rwIns = 1 To rwWk + 1
　　　　kPot = InStr(rwDt, ",")
　　　　Range("F" & rw + rwIns) = Left(rwDt, kPot - 1)
　　　　rwDt = Right(rwDt, Len(rwDt) - kPot)　'// 不要な数字をカット
　　　Next

　　　'// 行数を更新
　　　rw = rw + rwWk + 1
　　Wend
　End With
End Sub

お礼

ご丁寧にありがとうございます。
色々な方法が有るのですね。
私の発想の、まず難行行挿入するのか調べ
一気に行挿入して、そこから
転記するというのは、よろしくないというのが
わかりました。

回答No.7

kkkkkm

No5です。
解読の手助けになれば

> マクロを使わない手作業では

手作業と違う手順で行っています。

エクセルのVBAで行挿入を連続して行う場合、データのある最終行から行う方が行が増えたときに対象行の選択先を増えた行数分都度変更しなくてもいいため簡単になります。
上から行くと1行目が終わって2行増えた場合、次の対象はもとが2行目だったのに2行増えたから4行目を指定しなくてはいけなくなります。下からいくと何行増えても次の対象は3行目が終わったら2行目指定でいけます。

ですので
For i = Cells(Rows.Count, "F").End(xlUp).Row To 1 Step -1
最終行から1行目に向かってループします。

Fのi行のデータをmStr変数に格納しておきます。
これで、元のセルが行挿入でどこに移動しても対象とするFのi行のデータを保存しておけます。

Do～Loopでカンマの数を数えてます。Countにカンマの数が入ります。

Range(Cells(i, "A"), Cells(i + Count - 1, "A")).EntireRow.Insert
i行が3行目でカンマの数が2個とした場合A3とA4を選択して行挿入をします。
手動だとA3とA4を選択して挿入の行全体です。

Cells(i + j - 1, "F").Value = Left(mStr, InStr(mStr, ",") - 1)
保存した文字の先頭からカンマの前までを最初に対象としたセルに代入します。
mStr = Mid(mStr, InStr(mStr, ",") + 1)
次の処理で先頭からカンマの前までををセルに入れるために先に代入した文字分削除した文字列をmStrに保存します。
カンマで区切られた文字数分セルを一つずつ下に移動して繰り返します。

VBAをF8でステップ実行しながら画面を見ると状態が確認できます。

お礼

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

補足

ご丁寧にありがとうございます。

最初はFor～Nextで上から処理するようにしたのですが
ご指摘していただいた問題に気づき
下から処理には修正していました。
がその後が全然駄目で今は教えていただいたコードを
改造しようとしています。

F列に8,9と有る場合
↓
For i = Cells(Rows.Count, "F").End(xlUp).Row To 1 Step -1
mStr = Cells(i, "F").Value
Count = 0: n = 0←ここで0にして
Do
n = InStr(n + 1, mStr, ",")
↑ここでnに2が入り、これは、カンマで区切った値が2個？
という意味でしょうか？　
If n = 0 Then←2は0と等しくないのでElseへ飛び
Exit Do
Else
Count = Count + 1←初期値の0が+1されてCountが１になり
End If
Loop←Doに戻る

で2回目のDoに入って
n = InStr(n + 1, mStr, ",")
↑ここでnに0が入るのですが、ここがわからないです。
なぜここでnが0になるのか。　

If n = 0 Then←0と等しいのでDoを抜けます
Exit Do
Else
Count = Count + 1←Doを抜けたからここは処理されず1回目の1のままです
End If
Loop←Doに戻る

Range(Cells(処理行, "A"), Cells(処理行 + Count - 1, "A")).EntireRow.Insert

　　↑ここで行挿入されて
mStr = mStr & ","

　　↓For　Next　でF列に転記
For j = 1 To Count + 1
Cells(処理行 + j - 1, "F").Value = Left(mStr, InStr(mStr, ",") - 1)

　　　行挿入されて、元の行がConutの分さがったので

選択行　＝　処理行+Count
↑処理している行にその分足してコピーして、処理している
　行が空白のはずだからそこに貼付
Range(Cells(選択行, 1), Cells(選択行, 5)).Copy
Range(Cells(処理行, 1), Cells(処理行, 5)).PasteSpecial
Application.CutCopyMode = False
mStr = Mid(mStr, InStr(mStr, ",") + 1)
Next j

と考えましたが動きません。

回答No.6

f272

#1です。
行挿入と言ってますが，F列とA～E列以外には挿入処理は行いません。(もしかしてそうじゃないほうがよかったですか？)
コメントも色々とつけておきました。#1のコメント見るとInStr関数の意味を誤解しているようです。これは文字列の中でのカンマの位置を返しているのであって，カンマの数を調べているわけではありません。
それから1回のループでは1行分しか挿入操作は行いません。それをカンマの数だけ繰り返しています。

Sub Sample()
Set key = Range("F1") 'カンマの入ったデータ列の最初の行
Set Rng = Range("A1:E1") '同時に行挿入する列の最初の行
Do
If key.Value = "" Then Exit Do 'keyが空白ならループ脱出
i = InStr(key, ",") 'keyの最初のカンマの位置を調べる
If i <> 0 Then 'keyの中にカンマが見つかれば
key.Offset(1).Insert Shift:=xlDown 'keyのセルの1行下に空白を挿入
kv = key.Value 'keyの値をいったん覚えて
key.Value = Left(kv, i - 1) 'keyの値のカンマの前までをkeyのセルに入れる
Set key = key.Offset(1) 'keyを1行下に変更して
key.Value = Right(kv, Len(kv) - i) '元のkeyの値のカンマのあとから最後までを新しいkeyのセルに入れる
Rng.Copy 'rngのセルの内容をコピー
Rng.Insert Shift:=xlDown 'rngのセルの1行下にコピーした内容を挿入
Else 'keyの中にカンマの位置が見つからなければ
Set key = key.Offset(1) 'keyを1行下に変更
End If
Loop
Application.CutCopyMode = False 'セル範囲の枠線の点滅表示を無しにする
End Sub

お礼

丁寧な説明を付けていただきまして
ありがとうございます。
説明が下手で申し訳ございません。

補足

すばやい回答ありがとうございます。
説明が下手ですいません。

F1に1,7,9
F2に3,5
の場合
F1の下に2行増えて
F1に1
F2に7
F3に9
で
A1～E1までの値を
A2～E2と
A3～E3にコピーしたいです。
教えていたコードは
こう動きました。

でもともと2行目にいた
F2の3,5は
F4に3
F5に5
となりますが
もともと
A2～E2にいたデータが
A4～E4と
A5～E5に貼り付けたいです。

Set Rng　思い出しました。
ですが最初にA1～E1をセットしてしまうので
すべての行が元々1行名のA1～E1になってしまいます。

求めているのはこんな感じです。
F1に1,7,9
A1→かき
B1→なし
C1→みかん
D1→もも
E1→りんご

F2に3,5
A2→いも
B2→ねぎ
C2→れたす
D2→とまと
E2→にく

F1に1
A1→かき
B1→なし
C1→みかん
D1→もも
E1→りんご

行挿入されて
F2に7
A2→かき
B2→なし
C2→みかん
D2→もも
E2→りんご
（1行目と同じ）

F3に9
A2→かき
B2→なし
C2→みかん
D2→もも
E2→りんご
（1行目と同じ）

元々のF2の3,5は
4行目となり
F4に3で
A4→いも
B4→ねぎ
C4→れたす
D4→とまと
E4→にく
（元々2行目に居た値で、この時点では4行目にいました）

F5には5で
A5→いも
B5→ねぎ
C5→れたす
D5→とまと
E5→にく
（元々2行目に居た値でこの時点では4行目に居た値）
F列にカンマが無い場合は
処理しないので
その列のA～Eの値は元のままです。

でもF1に1,7,9といた場合
１、7と転記後は最後は9だけで
カンマはいませんがこの時は行挿入前の1,7,9の時の
A～E列をコピーしたいです。
最初からカンマがいない時との区別が付けれません。
この両立させる方法が思いつきません。

>F列とA～E列以外には挿入処理は行いません。
>(もしかしてそうじゃないほうがよかったですか？)

そういう意味では全列挿入の方がよかったのかな？です。
自分が考えたイメージは
カンマの数を数えて、その数の分を
行挿入（この時点で全列空白）
で、カンマで区切られた文字を取り除いて
F列に入れて、A列～E列は行挿入前の値を
貼りつけ、でもこの時点で元々2行目に居た
A列～E列はすでに2行目にはいないわけで
それをどうやって記憶させておくか
思いつきません。

教えていただいたコード、
最初にA1～E1をセットしているから
全行これが貼りつけされてしまうので
カンマが有る行を見つけたらその行番号を
変数に代入すれば出来るかと改造しましたが
駄目でした。

For Nextですと、変数に処理している行が
入りますがDo　Loopですとそういう概念は無い？
私の考え根本的に間違ってますよね。
申し訳ありません。

Sub 実験()
Set Key = Range("F1") 'カンマの入ったデータ列の最初の行
'Set Rng = Range("A1:E1") '同時に行挿入する列の最初の行
Do
If Key.Value = "" Then Exit Do 'keyが空白ならループ脱出
i = InStr(Key, ",") 'keyの最初のカンマの位置を調べる
If i <> 0 Then 'keyの中にカンマが見つかれば
処理行 = Row'カンマが見つかった行数を変数へ
Set Rng = Range(Cells(処理行, 1), Cells(処理行, 5))
Key.Offset(1).Insert Shift:=xlDown 'keyのセルの1行下に空白を挿入
kv = Key.Value 'keyの値をいったん覚えて
Key.Value = Left(kv, i - 1) 'keyの値のカンマの前までをkeyのセルに入れる
Set Key = Key.Offset(1) 'keyを1行下に変更して
Key.Value = Right(kv, Len(kv) - i) '元のkeyの値のカンマのあとから最後までを新しいkeyのセルに入れる
Rng.Copy 'rngのセルの内容をコピー
Rng.Insert Shift:=xlDown 'rngのセルの1行下にコピーした内容を挿入
Else 'keyの中にカンマの位置が見つからなければ
Set Key = Key.Offset(1) 'keyを1行下に変更
End If
Loop

回答No.5

kkkkkm

No2No3です。
補足の例(F列が基準で行挿入)にあわせると以下2点です。

配列を使ったコード
Sub Test()
Dim mStr As Variant
Dim i As Long, j As Long

For i = Cells(Rows.Count, "F").End(xlUp).Row To 1 Step -1
mStr = Split(Cells(i, "F"), ",")
If UBound(mStr) > 0 Then
Range(Cells(i, "A"), Cells(i + UBound(mStr) - 1, "A")).EntireRow.Insert
For j = LBound(mStr) To UBound(mStr)
Cells(i + j, "F").Value = mStr(j)
Next j
End If
Next i
End Sub

配列を使わないコード
Sub Test2()
Dim i As Long, j As Long
Dim n As Long, Count As Long
Dim mStr As String, buf As String

For i = Cells(Rows.Count, "F").End(xlUp).Row To 1 Step -1
mStr = Cells(i, "F").Value
Count = 0: n = 0
Do
n = InStr(n + 1, mStr, ",")
If n = 0 Then
Exit Do
Else
Count = Count + 1
End If
Loop
If Count > 0 Then
Range(Cells(i, "A"), Cells(i + Count - 1, "A")).EntireRow.Insert
mStr = mStr & ","
For j = 1 To Count + 1
Cells(i + j - 1, "F").Value = Left(mStr, InStr(mStr, ",") - 1)
mStr = Mid(mStr, InStr(mStr, ",") + 1)
Next j
End If
Next i
End Sub

お礼

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

補足

ありがとうございます。

早速使用させていただきました。
他の列も行挿入に従って一緒に下がりました。

説明が下手で申し訳ありません。

マクロを使わない手作業では

1行目のF列に1,5,9とある
カンマでくぎられた、値が3個有る。
2行目にカーソルをおいて
2行、行挿入
これで2行目と3行目には
全列空白の行が出来ます。
で1列目の行全体をコピーし
2行目、3行目に貼り付けます。
この時点で1行目、2行目、3行目が
全て同じ内容になります。

次にF列の整理です。
1行目も、2行目も、3行目も
1,5,9となっているはずですから
1行目は1
2行目は5
3行目は9
と手入力すれば完成です。
つぎは元々2行目にいた物が
この時点で4行目になっていますから
4行目のF列のカンマの数を見て
5行目にカーソルを当て、その数の行挿入を行い
4行目を行コピーして挿入した行に貼付け
F列の修正です。
でF列にカンマが無い行はこの処理は行わない。
です。

教えていただいたコードを解読して
うまく他列の値を貼り付けれればいいのですが
不安です。

回答No.4

nishi6

＞というマクロを作成したいのですが
質問にある手順通りに書いたら、下記になりました。
配列なしで、「番兵(rwDt = rwDt & ",")」を使っているので「If」なしです。

Sub insertRow()
　Dim rw As Long　　　　'// 全体の行カウンタ
　Dim rwWk As Long　　　'// 挿入する行数
　Dim rwIns As Long　　 '// 挿入する行カウンタ
　Dim rwDt As String　　'// カンマを含んだ値
　Dim kPot As Integer　 '// カンマの位置

　rw = 0
　With ActiveSheet.Range("A1")
　　While .Offset(rw, 0) <> ""
　　　'// カンマの数を計算
　　　rwDt = .Offset(rw, 0).Value
　　　rwWk = Len(rwDt) - Len(Application.Substitute(rwDt, ",", ""))
　　　'// 必要行数を挿入
　　　Range("A" & rw + 1 + 1, "A" & rw + rwWk + 1). _
　　　　　　Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
　　　'// 各数字を書き込む
　　　rwDt = rwDt & ","
　　　For rwIns = 1 To rwWk + 1
　　　　kPot = InStr(rwDt, ",")
　　　　Range("A" & rw + rwIns) = Left(rwDt, kPot - 1)
　　　　rwDt = Right(rwDt, Len(rwDt) - kPot)　'// 不要な数字をカット
　　　Next

　　　'// 行数を更新
　　　rw = rw + rwWk + 1
　　Wend
　End With
End Sub

質問にある手順を無視して結果重視で書くと、下記になりました。行挿入処理がなくなります。

Sub insertRow2()
　Dim rw As Long　　　　'// 全体の行カウンタ
　Dim rwWk As Long　　　'// 挿入する行数
　Dim rwIns As Long　　 '// 挿入する行カウンタ
　Dim rwDt As String　　'// カンマを含んだ値
　Dim kPot As Integer　 '// カンマの位置

　With ActiveSheet.Range("A1")
　　'// データを全てまとめる
　　rwDt = .Value: rw = 1
　　While .Offset(rw, 0) <> ""
　　　rwDt = rwDt & "," & .Offset(rw, 0).Value
　　　rw = rw + 1
　　Wend
　　'// カンマの数を計算
　　rwWk = Len(rwDt) - Len(Application.Substitute(rwDt, ",", ""))
　　'// 各数字を書き込む
　　rwDt = rwDt & ","
　　For rwIns = 1 To rwWk + 1
　　　kPot = InStr(rwDt, ",")
　　　Range("A" & rwIns) = Left(rwDt, kPot - 1)
　　　rwDt = Right(rwDt, Len(rwDt) - kPot)
　　Next
　End With
End Sub

お礼

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

補足

ありがとうございます。
IFを使用しないでも
出来るのですね。

あと大変申し訳ありません。
説明不足でした。
考え方を知りたくて　例　で質問してしまいました。

本番で実行したいのは
カンマが入ったデータはF列でして、F列を基準に処理を行うのですが
A～E列にも別なデータが有ります。
行挿入したら、A～E列はデータは変化させないで、
そのまま行だけ下がらせたいです。

セルF1に1,2,3
セルA1にあ
セルB1に五
セルC1にア
セルD1にＡ
セルE1に本
と入力されていたとして

F1のセルのカンマは2個ですから
2行下がります。
F1に1
F2に2
F3に3
でももともと1行目にあった各データ
をそのまま挿入された行に転記したいので
セルA1、A2、A3にあ
セルB1、B2、B3に五
セルC1、C2、C3にア
セルD1、D2、D3にＡ
セルE1、E2、E3に本
という具合です。

教えていただきました内容を、試しましたが
勿論、質問どうりに正しく動きました。
教えていただいたのはA列を基準ですから
B列からF列に仮データを入力して試したのですが
A列のみのデータが変化し、B列以降のデータは
行は下がらずそのままの位置に固定されたままです。
キチンと説明しなかったので当然なのですが。
ちょっと、私の能力では、教えていただいたコードを
改造し自分が求めるコードにするのは困難です。
申しわけございません。

処理が理解できた回答NO.1のf272様のコードを
別な処理も含めて改造してみた物の
自分が求める様には改造できませんでした。

最初からきちんと質問すべきで回答していただいた皆様に
ご迷惑をおかけしてしまいました。
お手数をおかけして申し訳ございませんでした。

Sub 挿入()

Dim 挿入数
Dim 元値
Dim 選択行
Dim 複写行

Range("F4").Select
Do
元値 = Selection
If 元値 = "" Then Exit Do 'セルの値が空白ならDoを抜ける
挿入数 = InStr(元値, ",") 'カンマの数を数えて挿入数に代入
If 挿入数 <> 0 Then '挿入数が0以外なら処理続行。0ならELSEへ
Selection.Offset(1).Insert Shift:=xlDown '行挿入
Selection = Left(元値, 挿入数 - 1) '元値を変換して転記
Selection.Offset(1).Select
選択行 = Selection.Row
複写行 = 選択行 - 1
Range(Cells(複写行, 1), Cells(複写行, 5)).Copy
Range(Cells(選択行, 1), Cells(選択行, 5)).PasteSpecial
Application.CutCopyMode = False
Selection = Right(元値, Len(元値) - 挿入数) '元値から転記済を除いて転記
Else
Selection.Offset(1).Select
End If
Loop
End Sub