EXCELで条件を満たす時コピー挿入したい

質問

EXCEL2002ですが、以下のようなデータがあるとします。

　　　　　A　　　　　　B
1　　　　山田太郎　100
2　　　　山田花子　100,200,300
3　　　　鈴木一郎　300

B列にカンマ区切りで入力しているデータがある場合、

　　　　　A　　　　　　B
1　　　　山田太郎　100
2　　　　山田花子　100
3　　　　山田花子　200
4　　　　山田花子　300
5　　　　鈴木一郎　300

上記のように、B列のカンマ区切り分を振り分けたレコードを新たに
挿入したいのです。

尚参考までに、A列は名前などでデータ内容は多様になり、B列は
ある程度決まった選択肢（20～30通り）になります。

一般の関数では無理なような気がするのですが、VBAなどでは可能でしょうか？
もし可能であれば、マクロなども組んだことがないものですから、
やさしくご教授いただければ幸いです。
よろしくお願いいたします。

回答No.2

eipu · ベストアンサー

下記で動くと思います。
B列が文字列であればの話ですが・・・。

Sub sample()
Dim COL_B() As String
Dim y As Long
Dim i As Integer
Dim n As Integer

y = 1

Do Until Cells(y, 2).Value = ""
If InStr(Cells(y, 2).Value, ",") > 0 Then
COL_B = Split(Cells(y, 2).Value, ",")
n = UBound(COL_B)
For i = 0 To n
If i <> 0 Then Cells(y + i, 1).Value = Cells(y, 1).Value
If i <> n Then Rows(y + i + 1).Insert shift:=xlDown
Cells(y + i, 2).Value = COL_B(i)
Next
End If
Application.StatusBar = y
y = y + 1
Loop

End Sub

お礼

B列は文字列なのでこれで問題ありません。
イメージ通りです。
ありがとうございました。

回答No.3

imogasi

Ａ１にＡ、Ａ２にＢ、
Ｂ１に「’１００，２００」、Ｂ２に「’３００，４００，５００」といれてテストしました。「’」なしだと
位取りの「，」となってしまうので、「’」を先頭にいれたデータとしました。
Sub test01()
j = 1
For i = 1 To 2
s = Cells(i, "B")
t = 1
p01:
p = InStr(t, s, ",")
If p = 0 Then
Cells(j, "C") = Cells(i, "A")
Cells(j, "D") = Mid(s, t, Len(s) - (p + 1))
j = j + 1
flag = "n"
Else
Cells(j, "C") = Cells(i, "A")
Cells(j, "D") = Mid(s, t, p - 1 - (t - 1))
j = j + 1
t = p + 1
flag = "y"
End If
If flag = "y" Then GoTo p01
Next i
End Sub
結果は
Ａ 100
Ａ 200
Ｂ 300
Ｂ 400
Ｂ 500
です。
，での分離にＳｐｌｉｔ関数が使えるかも知れませんが、自信がなくて、取り急いだのでテストしていません。チェックして見てください。

お礼

この方法でも応用出来そうです。参考になります。
ありがとうございました。

色々なアプローチの仕方があって、どの手法が最適なのかわかりませんが、
今回は一番イメージ通りのeipuさんに20Ｐとさせていただきます。
全部思い通りに出来る回答なので心苦しいのですが…
本当にありがとうございました。

回答No.1

nishi6

コードを書いてみました。
行の挿入をしないで、別シートに書いてみました。応用してみて下さい。
Sheet1の内容をSheet2に書き換えています。

標準モジュールに貼り付けます。

Sub Bunri()
　　Dim rw1 As Long 'Sheet1の行カウンタ
　　Dim rw2 As Long 'Sheet2の行カウンタ
　　Dim sep As Integer 'カンマの個数
　　Dim Bnum As String 'B列の文字
　　Dim Bpot As Integer 'カンマの位置

　　Dim ws1 As Worksheet, ws2 As Worksheet
　　Set ws1 = Worksheets("Sheet1")
　　Set ws2 = Worksheets("Sheet2")

　　For rw1 = 1 To Range("A65536").End(xlUp).Row

　　　　Bnum = ws1.Range("B" & rw1) & ","
　　　　For sep = 1 To Len(Bnum) - Len(Application.Substitute(Bnum, ",", ""))
　　　　　　Bpot = InStr(Bnum, ",")
　　　　　　rw2 = rw2 + 1
　　　　　　ws2.Range("A" & rw2) = ws1.Range("A" & rw1)
　　　　　　ws2.Range("B" & rw2) = Left(Bnum, Bpot - 1)

　　　　　　Bnum = Mid(Bnum, Bpot + 1)
　　　　Next

　　Next
End Sub

お礼

早速のご回答ありがとうございました。
これなら色々応用できそうです。
勉強になりました。