一つのセルにあるデータを項目別に複数列に分割したい

質問

一つのセルにあるデータを項目別に複数列に分割したいです。
初歩な質問かも知れませんが教えて下さい。Excel 2010使用です。
一つのセルに「」に囲まれた項目別のデータが全て詰まっています。「」に囲まれた複数の文字列は項目名が書かれているのですが、これを分割し、列の先頭に項目名を付けて分割したいです。A2のセルから1列にデータが入っており、セル内にある項目は「郵便番号」「住所」「氏名」「電話番号」「誕生日」「血液型」。
これを分割していきたいのですが、必ずしも全てのデータが入っているわけではなく、データが欠けているものがあります。添付の2行目のような結果を出す関数やマクロなど、わかりましたらご教授いただけないでしょうか・・・。（画像が小さいため、A列とB～G列と分割しました。わかりづらくスミマセン。）
たくさん調べたのですが、なかなか当てはまるものが見つからず、お力を貸してください。。

回答No.1

tom04 · ベストアンサー

こんにちは！

画像通りB列以降の項目は「郵便番号」のように「」で囲まれているという前提です。
VBAでの一例です。

画面左下の操作したいSheet見出し上で右クリック　→　コードの表示　→　VBE画面のカーソルが点滅しているところに
↓のコードをコピー＆ペースト　→　Excel画面に戻りマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

尚、画像を見る限りにおいては「　の前に半角スペースがあるように見えますので、
「　の前には半角スペースがあるという前提でのコードです。

Sub Sample1()
Dim i As Long, j As Long, k As Long, myArry
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
myArry = Split(Cells(i, "A"), " ")
For k = 0 To UBound(myArry)
For j = 2 To 7
If InStr(myArry(k), Cells(1, j)) > 0 Then
Cells(i, j) = Replace(myArry(k), Cells(1, j), "")
End If
Next j
Next k
Next i
ActiveSheet.Columns.AutoFit
End Sub

※　もし、「　の前にはスーペースがなく、連続して文字が入力されている場合は
↓のコードでマクロを試してみてください。

Sub Sample2() '「　の前に半角スペースがない場合
Dim i As Long, j As Long, k As Long, myArry
Range("A:A").Copy Range("H1")
Range("H:H").Replace what:="「", replacement:=" 「", lookat:=xlPart
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
Cells(i, "H") = Trim(Cells(i, "H"))
myArry = Split(Cells(i, "H"), " ")
For k = 0 To UBound(myArry)
For j = 2 To 7
If InStr(myArry(k), Cells(1, j)) > 0 Then
Cells(i, j) = Replace(myArry(k), Cells(1, j), "")
End If
Next j
Next k
Next i
Range("H:H").Clear
ActiveSheet.Columns.AutoFit
End Sub

こんな感じではどうでしょうか？m（_ _）m

お礼

ばっちり出来ました！！感激です！
VBAで色々なことが可能になるんですね・・！
助かりました！！ありがとうございます～！！

回答No.2

bunjii

>たくさん調べたのですが、なかなか当てはまるものが見つからず、お力を貸してください。。
文字列の切り出しを行うにはMID関数が有効です。
=MID(元の文字列,開始位置,文字数)
開始位置はFIND関数で検出します。
=FIND(検索文字列,元の文字列,検索開始位置)
また、検索時にエラーが発生したとき代替の値を指定するにはIFERROR関数が有効です。
=IFERROR(数式,代替値)
更に、項目名を除くにはLEN関数も必要です。
=LEN(項目名）

B2=IFERROR(MID($A2,FIND(B$1,$A2)+LEN(B$1),IFERROR(FIND("「",$A2,FIND(B$1,$A2)+1)-FIND(B$1,$A2)-LEN(B$1),LEN($A2))),"")
B2セルを右へG2セルまでコピーし、そのまま、下へ必要数コピーすれば良いでしょう。

貼付画像はExcel 2013で検証した結果ですが、Excel 2007以降のバージョンで同様な結果になるはずです。

お礼

関数でバッチリ出来ました～！
わたしは全く応用がわからず、本当に助かりました！！
ありがとうございます！