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

質問

エクセル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.3

kkkkkm

No2です。
配列を使わないで
> For～Nextで回して
> セルA1のカンマの数を
> InStr関数で数えて
> カンマが3個だから
> その3を変数に入れて
> それを利用して
> A2から3行行挿入します。

このイメージのようにしてみました。

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, "A").End(xlUp).Row To 1 Step -1
mStr = Cells(i, "A").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")).Insert (xlShiftDown)
mStr = mStr & ","
For j = 1 To Count + 1
Cells(i + j - 1, "A").Value = Left(mStr, InStr(mStr, ",") - 1)
mStr = Mid(mStr, InStr(mStr, ",") + 1)
Next j
End If
Next i
End Sub

お礼

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

補足

ありがとうございます。
私の能力では解読に
時間がかかりそうです。

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

本番で実行したいのは
カンマが入ったデータは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

回答No.2

kkkkkm

配列を使いますが・・・
Sub Test()
Dim mStr As Variant
Dim i As Long, j As Long

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

お礼

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

補足

ありがとうございます。
やはり配列は、難しいです。
昔1回作成したことが有りますが
今見ると解読できないので
まだ身についておりません。

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

本番で実行したいのは
カンマが入ったデータはF列でして、F列を基準に処理を行うのですが
A～E列にも別なデータが有ります。
行挿入したら、A～E列はデータは変化させないで、
そのまま行だけ下がらせたいです。
セルF1に1,2,3
セルA1にあ
セルB1に五
セルC1にア
セルD1にＡ
セルE1に本

カンマは2個ですから
2行下がります。
F1に1
F2に2
F3に3
セル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

回答No.1

f272

配列を使いたくないなら，こんな感じ
Sub Sample()
Range("a1").Select
Do
a = Selection
If a = "" Then Exit Do
i = InStr(a, ",")
If i <> 0 Then
Selection.Offset(1).Insert Shift:=xlDown
Selection = Left(a, i - 1)
Selection.Offset(1).Select
Selection = Right(a, Len(a) - i)
Else
Selection.Offset(1).Select
End If
Loop
End Sub

お礼

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

補足

ありがとうございます。
これでしたら、私でもわかります。

ただ説明不足でした。

考え方を知りたくて例で質問してしまいました。

やりたいのは
カンマが入ったデータはF列でして、A～E列にもデータが有ります。
行挿入したら、A～E列も一緒に下がってほしいのですが
教えていただきました内容を、F列に置き換えて
別な処理も含めて作成しましたが
F列だけが単独で行挿入されてしまいます。
Selection.Offset(1).Insert Shift:=xlDown
の部分を改造しないといけないのかと思っているのですが
思うようにいきません。

考え方を教えてもらい、あとは自力でと
思ったのですが、能力不足でできません。
申しわけございません。

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