エクセルのマクロ 【】の中だけ抽出〒と住所を分ける

質問

あるデータからコピペしてエクセルに並べ替えたいのですが

例えば
山田　太郎【やまだ　たろう】
〒123-4567　東京都～

というデータをエクセルにペーストしました。

A２のセルには
山田　太郎【やまだ　たろう】

A３のセルには
〒123-4567　東京都～

が入力されたとします。

それを
B１とC1には
山田　太郎

D１には
やまだ　たろう

E１には
123-4567

F１には
東京都～

を入れたいのですがマクロで出来る方法を教えて下さい。

回答No.19

tom04 · ベストアンサー

ぎゃっはっはぁ～～！
結局前回で解決！とはいかなかった訳ですね？
確かに、一旦望み通りのコトが可能になると次への欲望が出てしまいますね。

さて、本題です。
結局A45セルにB4セルと同じ形式で名前が入っていて、H列に [　より前の名前を！
I列に　[ と ]　に囲まれた部分を表示したい！という解釈で・・・

Private Sub CommandButton1_Click()
Dim k As Long, cnt As Long, startStr As Long, lastStr As Long, str As String
Dim myShp As Shape
On Error Resume Next '←念のため
str = Left(Range("B4"), InStr(StrConv(Range("B4"), vbNarrow), "[") - 1)
If InStr(Range("B2"), "【") > 0 Then
k = InStr(Range("B2"), "【") - 1
Else
k = Len(Range("B2"))
End If
startStr = InStr(Range("B4"), "[") + 1
lastStr = InStr(Range("B4"), "]")
With Worksheets("Sheet2")
cnt = .Cells(Rows.Count, "A").End(xlUp).Row + 1
.Cells(cnt, "A") = Trim(Replace(Left(Range("B2"), k), vbLf, ""))
.Cells(cnt, "B").Resize(, 2) = Trim(Replace(str, "　", " "))
.Cells(cnt, "D") = Trim(Replace(Mid(Range("B4"), startStr, lastStr - startStr), "　", " "))
.Cells(cnt, "E") = Trim(StrConv(Range("B8"), vbNarrow))
.Cells(cnt, "F") = StrConv(Left(Trim(Replace(Range("B7"), "〒", "")), 8), vbNarrow)
.Cells(cnt, "G") = Trim(Replace(Replace(Range("B7"), "〒", ""), .Cells(cnt, "F"), ""))
.Cells(cnt, "J") = Trim(Replace(UCase(StrConv(Range("A48"), vbNarrow)), "TEL:", ""))
.Cells(cnt, "K") = Trim(Replace(Range("A46"), "〒", ""))
.Cells(cnt, "L") = StrConv(Range("A47"), vbNarrow)
'※　ココから追加
str = Left(Range("A45"), InStr(StrConv(Range("A45"), vbNarrow), "[") - 1)
startStr = InStr(Range("A45"), "[") + 1
lastStr = InStr(Range("A45"), "]")
.Cells(cnt, "H") = Trim(Replace(str, "　", " "))
.Cells(cnt, "I") = Trim(Replace(Mid(Range("A45"), startStr, lastStr - startStr), "　", " "))
'※　ココまで
'↓オブジェクトの削除（コマンドボタン以外）
For Each myShp In Worksheets("Sheet1").Shapes
If myShp.Type <> msoOLEControlObject Then
If myShp.OLEFormat.progID <> "Format.CommandButton1" Then
myShp.Delete
End If
End If
Next myShp
End With
'↑まで
Range("A:K").ClearContents
End Sub

こんなんではどうでしょうか？

※　こちらでは具体的な表のレイアウトが判らないので、補足にあるコードを参考に手を加えてみました。
K列表示がお望み通りになっていないかもしれません。m(_ _)m

お礼

私の説明不足な文章で理解していただき
とても使いやすいマクロを作っていただきまして
ありがとうございます！！

１時間かかっていた作業が
１０数分で出来る様になりました！

今までの作業は何だったんだろう？
といった感じです！

他のスタッフも喜んでおります！

感謝しております！
本当にありがとうございました！

補足

tom04様

てへ。申し訳ございません。
良く深くなってしまいました。

そして、出来ました！！！
バッチリです！

ついでに本日、１行目のボタンも下の方がいい！となり、
50行目に移動しちゃんと出来ました！

ありがとうございます！！！
ありがとうございます！！！
ありがとうございます！！！