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

質問

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

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

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

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

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

が入力されたとします。

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

D１には
やまだ　たろう

E１には
123-4567

F１には
東京都～

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

回答No.7

tom04

こんばんは！
補足を読みました。
最初のサイトはログインしなければならないので、見ていません。
尚、1件ずつしかコピー＆ペーストできないようなので、
↓の画像のようにSheet1にデータをコピー＆ペーストした後の操作となります。

＞出来ればボタンでポチっとで終わってくれるととっても嬉しいです
というコトですので、↓の画像のようにSheet1にコマンドボタンを挿入した上での方法です。

それから、
J2→　送付先電話番号半角数字とハイフンのみ。
K2→　送付先郵便番号（〒マークなし７桁の半角数字とハイフンのみ。）
L2→　都道府県からの送付先住所

に関してはセル番地が判らないので、今回は無視しています。
（画像のA列にこのデータがコピー＆ペーストできれば、可能だとは思いますが・・・）

コマンドボタンをクリックするたびにSheet1のデータをSheet2の最終行の次の行に表示するようにしています。

Private Sub CommandButton1_Click()
Dim k As Long, cnt As Long, startStr As Long, lastStr As Long, str As String

str = Left(Range("B3"), InStr(StrConv(Range("B3"), vbNarrow), "[") - 1)
If InStr(Range("B1"), "【") > 0 Then
k = InStr(Range("B1"), "【") - 1
Else
k = Len(Range("B1"))
End If
startStr = InStr(Range("B3"), "[") + 1
lastStr = InStr(Range("B3"), "]")
With Worksheets("Sheet2")
cnt = .Cells(Rows.Count, "A").End(xlUp).Row + 1
.Cells(cnt, "A") = Replace(Left(Range("B1"), k), vbLf, "")
.Cells(cnt, "B").Resize(, 2) = Replace(str, "　", " ")
.Cells(cnt, "D") = Trim(Replace(Mid(Range("B3"), startStr, lastStr - startStr), "　", " "))
.Cells(cnt, "E") = StrConv(Range("B7"), vbNarrow)
.Cells(cnt, "F") = Trim(Left(Replace(Range("B6"), "〒", ""), 8))
.Cells(cnt, "G") = Trim(Replace(Replace(Range("B6"), "〒", ""), .Cells(cnt, "F"), ""))
End With
End Sub

※　Sheet2に転記した後、Sheet1のデータを消去することは可能ですが、
敢えてその操作はしていません。m(_ _)m

お礼

tom04様
自分でやってみましたら出来ました！
tom04様のお陰です！！！！！！ありがとうございます！！！！！

別住所がある場合、上の住所と別住所を別々にコピーするのが面倒だなと途中で思ったので

【画像（1）】の赤く囲んでいるところから、モザイクをかけているところも一緒に
緑で囲んでいる所まで一気にコピーしてsheet1にペーストしました。

http://www.fastpic.jp/images.php?file=3812557730.jpg

緑で囲っている部分がsheet1のA27～A30だったり　A28からだったり情報によって位置違うので
自分でコピーして必ずA30～A32にペーストするようにしました。
変なところがあるでしょうか、、、？

Private Sub CommandButton1_Click()
Dim k As Long, cnt As Long, startStr As Long, lastStr As Long, str As String

str = Left(Range("B3"), InStr(StrConv(Range("B3"), vbNarrow), "[") - 1)
If InStr(Range("B1"), "【") > 0 Then
k = InStr(Range("B1"), "【") - 1
Else
k = Len(Range("B1"))
End If
startStr = InStr(Range("B3"), "[") + 1
lastStr = InStr(Range("B3"), "]")
With Worksheets("Sheet2")
cnt = .Cells(Rows.Count, "A").End(xlUp).Row + 1
.Cells(cnt, "A") = Replace(Left(Range("B1"), k), vbLf, "")
.Cells(cnt, "B").Resize(, 2) = Replace(str, "　", " ")
.Cells(cnt, "D") = Trim(Replace(Mid(Range("B3"), startStr, lastStr - startStr), "　", " "))
.Cells(cnt, "E") = StrConv(Range("B7"), vbNarrow)
.Cells(cnt, "F") = Trim(Left(Replace(Range("B6"), "〒", ""), 9))
.Cells(cnt, "G") = Trim(Replace(Replace(Range("B6"), "〒", ""), .Cells(cnt, "F"), ""))
.Cells(cnt, "J") = Trim(Replace(Replace(Range("A32"), "TEL： ", ""), .Cells(cnt, "F"), ""))
.Cells(cnt, "K") = Trim(Left(Replace(Range("A30"), "〒", ""), 9))
.Cells(cnt, "L") = StrConv(Range("A31"), vbNarrow)

End With
End Sub

＞※　Sheet2に転記した後、Sheet1のデータを消去することは可能ですが、
敢えてその操作はしていません。m(_ _)m

これも自分でマクロを組んでみましたが、オブジェクトが残ったり
オブジェクトも消せるようにするとマクロのボタンも消えたりとダメでした。

お願いできますでしょうか？

補足

tom04様
再度ご回答をいただきまして誠にありがとうございます。

最初の画面が見られず申し訳ございません。
ログインしなくても見られると思っておりました。
【画像（1）】 から【画像（5）】までが一覧で見られるサイトでした。

早速ですが、教えられた事をやってみたのですが
すごいです！！！！！本当にありがとうございます！

ですが、私のやり方がおかしかったのか、何度やってみましても
郵便番号の最後が住所の最初に付いて来てしまいました。

【画像（7）】 をご覧いただけたらと思います。
http://www.fastpic.jp/images.php?file=7639227841.jpg

＞それから、
J2→　送付先電話番号半角数字とハイフンのみ。
K2→　送付先郵便番号（〒マークなし７桁の半角数字とハイフンのみ。）
L2→　都道府県からの送付先住所
に関してはセル番地が判らないので、今回は無視しています。

こちらの件ですが、送付先が別　という事がイレギュラーで
あるので、ある場合は【画像（8）】の様に
B8～B10に入力する。
【画像（8）】
http://www.fastpic.jp/images.php?file=2649739340.jpg
送付先が同じ場合はB8～B10には何も入力しない方法で出来たらいいなと思うのですが、

sheet1B8の郵便番号はsheet2のK列に〒マーク無しで半角数字とハイフンのみ。
sheet1B9の住所はsheet2のL列に都道府県から
sheet1B10の電話番号は情報はTEL： を取ってsheet2のj列に半角数字とハイフンのみで
表示出来る様にしていただけると大変助かります！

sheet2のHとJ列は空白でお願いいたします。

誠に図々しいお願いとは承知の上でございます。
お時間を取らせてしまいまして申し訳ございませんが
どうぞ宜しくお願いいたします。