文字列の数抽出、行挿入マクロ

質問

急きょ下記処理を実施することになったのですが、本やネットで下記処理ができるような
マクロを色々探していもなかなか見つからず…。（T_T)
どなたか詳しい方がいらっしゃいましたら教えていただけませんでしょうか？

・A列に特定の文字列(；）があった場合、その列をコピー。
・その列の下に文字列（；）の数と同数の行を挿入。
・挿入した行のAセルに、文字列（；）のすぐ後ろの１ケタを貼り付け。
・（挿入行が２行の場合） さらに下に挿入した行のAセルに、左から２つ目の文字列（；）の
　すぐ後ろの１ケタを貼り付け。

なお、Ａ列の行数は、現時点で５００行ほどあり、今後増える可能性もあります。

【処理する前】

　　　　　　Ａ列　　　　　　Ｂ列　　　 Ｃ列
１行目　　１；３２　　　　 ５５５　　　ＡＡＡ
２行目　　２９；１；４　　 ２２２　　　ＧＧＧ
３行目　　６００　　　　　 １１１　　　ＦＦＦ

【マクロ実行後】

　　　　　　Ａ列　　　　Ｂ列　　　Ｃ列
１行目　　１　　　　　５５５　　　ＡＡＡ
２行目　　３２　　　　５５５　　　ＡＡＡ
３行目　　２９　　　　２２２　　　ＧＧＧ
４行目　　１　　　　　２２２　　　ＧＧＧ
５行目　　４　　　　　２２２　　　ＧＧＧ　
６行目　　６００　　　１１１　　　ＦＦＦ

どうぞよろしくお願いいたします。

回答No.3

Wendy02 · ベストアンサー

すでに回答が出来上がっていますから、参考にしていただければ幸いです。
区切り文字は、半角でも全角でも可能です。(TextCompare Mode)
列数は可変ですから、3列とは決まっていません。出力場所を選びません。
貼り付け場所の
Range("A1").Resize(n, col).Value = ar2
のA1部分を指定してください。他のシートでも可能です。例：Sheet2.Range("A1").Res……

'//
Sub Test3()
　Dim rng As Range
　Dim i As Long, j As Long, k As Long, n As Long, m As Long, col As Long
　Dim ar0 As Variant
　Dim ar1 As Variant
　Dim ar2() As Variant
　Set rng = Range("A1").CurrentRegion
　ar0 = rng.Value
　col = rng.Columns.Count
　For i = 1 To rng.Rows.Count
　　ar1 = Split(ar0(i, 1), ";", , 1)
　　k = UBound(ar1)
　　For j = 0 To k
　　　ReDim Preserve ar2(col - 1, n)
　　　ar2(0, n) = ar1(j)
　　　For m = 2 To col
　　　　ar2(m - 1, n) = ar0(i, m)
　　　Next m
　　　n = n + 1
　　Next j
　Next i
　ar2 = Application.Transpose(ar2)
　'貼り付け場所
　Range("A1").Resize(n, col).Value = ar2
End Sub

お礼

お礼が遅くなり申し訳ありません。
皆様のおかげで無事処理が出来ました。
一番わかりやすく説明して頂いたwendyさんをベストアンサーと
させて頂きました。
本当にありがとうございました。

回答No.4

tom04

こんにちは！

数値とセミコロンは半角としています。
（全角の場合はうまく動作してくれないと思います）

一例です

Sub test()
Dim i As Long
i = 1
Do Until Cells(i, 1) = ""
If Cells(i, 1) Like "*" & ";" & "*" Then
Rows(i + 1).Insert
With Cells(i + 1, 1)
.Value = Mid(Cells(i, 1), WorksheetFunction.Find(";", Cells(i, 1)) + 1, _
Len(Cells(i, 1)) - WorksheetFunction.Find(";", Cells(i, 1)))
.Offset(, 1) = Cells(i, 2)
.Offset(, 2) = Cells(i, 3)
.Offset(-1) = Replace(Cells(i, 1), ";" & Cells(i + 1, 1), "")
End With
End If
i = i + 1
Loop
End Sub

こんな感じではどうでしょうか？m(__)m

お礼

お礼が遅くなり申し訳ありません。
皆様のおかげで無事処理が出来ました。
本当にありがとうございました。

回答No.2

mshr1962

一例ですが
Sub SCINC()
Dim RM As Range
For i = Range("A1").End(xlDown).Row To 1 Step -1
Set RM = Range("A" & i)
CM = Split(RM, ";")
If UBound(CM) > 0 Then
Rows(i + 1 & ":" & i + UBound(CM)).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
For j = 0 To UBound(CM)
RM.Offset(j, 0) = CM(j)
RM.Offset(j, 1) = RM.Offset(0, 1)
RM.Offset(j, 2) = RM.Offset(0, 2)
Next j
End If
Next i
End Sub

お礼

お礼が遅くなり申し訳ありません。
皆様のおかげで無事処理が出来ました。
本当にありがとうございました。

回答No.1

jcctaira

Sub 分割処理()
　Dim I　　　　　　As Long
　Dim J　　　　　As Long
　Dim 最終セル As Range
　Dim 分割　　 　As Variant
　Dim 分割数　 　As Long

　Set 最終セル = Cells(Rows.Count, "A").End(xlUp)
　I = 1
　Do While (I <= 最終セル.Row)
　　分割 = Split(Cells(I, "A"), "；")
　　分割数 = UBound(分割)
　　For J = 0 To 分割数
　　　If J <> 0 Then
　　　　Cells(I + J, "A").EntireRow.Copy
　　　　Cells(I + J, "A").EntireRow.Insert Shift:=xlDown
　　　End If
　　　If 分割数 <> 0 Then Cells(I + J, "A") = 分割(J)
　　Next J
　　I = I + 分割数 + 1
　Loop
　Application.CutCopyMode = False
End Sub

注）";"は全角か半角か分からなかったので、全角で作成しています。

お礼

お礼が遅くなり申し訳ありません。
皆様のおかげで無事処理が出来ました。
本当にありがとうございました。