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

質問

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

例えば
山田　太郎【やまだ　たろう】
〒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行目に移動しちゃんと出来ました！

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

回答No.9

tom04

続けてお邪魔します。

郵便番号以降にスペースがあったのですね。
今回はスペースがあっても、なくても対応できるようにしてみました。

尚、郵便番号・電話番号に関しては半角という前提です。
↓のコードに変更してみてください。

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") = StrConv(Left(Trim(Replace(Range("B6"), "〒", "")), 8), vbNarrow)
.Cells(cnt, "G") = Trim(Replace(Replace(Range("B6"), "〒", ""), .Cells(cnt, "F"), ""))
.Cells(cnt, "J") = Trim(Replace(Range("B8"), "〒", ""))
.Cells(cnt, "K") = Trim(Replace(UCase(StrConv(Range("B10"), vbNarrow)), "TEL:", ""))
.Cells(cnt, "L") = Range("B9")
End With
End Sub

※　Sheet1の8行目以降にデータがあってもなくても構いません。m（_ _）m

回答No.8

kagakusuki

アップロードされた画像を拝見致しましたが、不明な点が多々御座いますので、下記の点に関して御教え願います。

　まず、アップロードされた【画像（2）】において、セルの枠線が消えてしまっているために、どのセルにどのデータが入力されているのかが判りません。

　一見しますと、B1セルに「000000-11111111-2222222222 【スマートフォン】【ポイント】」という文字列データが入力されていて、
B2セルに「2014/2/22 15:37」というシリアル値の日時データが入力されていて、
B3～B5の３つのセルが結合されて１つとなったセルに

「山田 太郎[ヤマダ タロウ](改行)
ああああああああああああああ1@いいいいいいいいい(改行)
男 19××年×月×日生」

という文字列データが入力されていて、
B6セルに「〒 000-1111 東京都～」
B7セルに「090-****-****」という文字列データが入力されている様に見えます。
　しかしながら、B1セルにのみ

「000000-11111111-2222222222 【スマートフォン】【ポイント】(改行)
2014/2/22 15:37(改行)
山田 太郎[ヤマダ タロウ](改行)
ああああああああああああああ1@いいいいいいいいい(改行)
男 19××年×月×日生(改行)
〒 000-1111 東京都～(改行)
090-****-****」

という文字列データが入力されていて、B2～B7セルには何も入力されていない様にも見えます。
　又、B3～B5の３つのセルが結合されているのかいないのかもはっきりとはしません。
　そのため、どのセルからデータを抽出すれば良いのかが、アップロードされた画像による情報だけでは判りません。

　それに、入力されている括弧等の文字が全角文字なのか、それとも前後に半角のスペースが入っている半角文字であるのかが、画像だけでは判りかねますので、マクロを組む上で、データの区切りを判断させる際に、半角文字を目印にすれば良いのか、それとも全角文字を目印にすれば良いのか判りませんし、途中に含まれている空白スペースの数が想定したものと異なっていますと、正しい位置でデータを分離する事が出来ません。

　ですから、アップロードされた【画像（2）】に写っている文字列の内、何処からどこまでの文字列が、どのセルに入力されているのかという事を御教え願います。
　その際、もし、「2014/2/22 15:37」というデータが単独でセルに入力されていた場合には、そのデータの形式がシリアル値による日時データであるのか、それとも単なる文字列データであるのかも御教え願います。
　又、「山田 太郎 [ヤマダ タロウ]」の「太郎」と「[」の間には、空白のスペースが挟まっているのか否かという事と、「[」や「]」は半角文字なのか、それとも全角文字なのか、という事も御教え願います。
　又、注文者住所の所において、「〒」マークと「000」との間には空白スペースが挟まっている様にも見えますが、この「〒」マークと数字との間には、必ず空白スペースが挟まっていて、尚且つ、郵便番号と都道府県名との間には、必ず空白スペースが挟まっているのかという事も御教え願います。
　又、注文者住所の所において、必ず先頭に「〒」マークが入っているのかという事も御教え願います。
　又、注文者住所の所において、郵便番号自体が記述されていないというパターンもあるのか否かという事も御教え願います。
　又、アップロードされた画像において、貼り付けられているデータは１件だけしかありませんが、２件目以降は何行目から始まっていて、各件ごとのデータは、何行ごとの周期で入力されているのでしょうか？

補足

No.8様
ご回答いただきまして、誠にありがとうございます。
こちらの説明不足が多々あり大変申し訳ございません。

アップロードされた画像を拝見致しましたが、不明な点が多々御座いますので、下記の点に関して御教え願います。

　まず、アップロードされた【画像（2）】において、セルの枠線が消えてしまっているために、どのセルにどのデータが入力されているのかが判りません。

＞わかり難くて大変申し訳ございません。

わかりやすくした画像をUP致しました。
【画像（2）】直し
http://www.fastpic.jp/images.php?file=0159963130.jpg

＞その際、もし、「2014/2/22 15:37」というデータが単独でセルに入力されていた場合には、

単独になります。

＞そのデータの形式がシリアル値による日時データであるのか、それとも単なる文字列データであるのかも御教え願います。
ユーザー定義　yyyy/m/d h:mmになっていました。

又、「山田 太郎 [ヤマダ タロウ]」の「太郎」と「[」の間には、空白のスペースが挟まっているのか否かという事と、
・漢字と[の間には半角スペースが入っております。
・漢字もフリガナも苗字と名前の間のスペースは半角です。

＞「[」や「]」は半角文字なのか、それとも全角文字なのか、という事も御教え願います。
ごめんなさい。わかりませんのでコピーしてみてもらえますでしょうか？
名前[ナマエ]　かっこの種類はこれです。→　[]

＞又、注文者住所の所において、「〒」マークと「000」との間には空白スペースが挟まっている様にも見えますが、
この「〒」マークと数字との間には、必ず空白スペースが挟まっていて
、尚且つ、郵便番号と都道府県名との間には、必ず空白スペースが挟まっているのかという事も御教え願います。

はい。必ず半角スペースが1つ入っております。

＞又、注文者住所の所において、必ず先頭に「〒」マークが入っているのかという事も御教え願います。
はい。必ず半角スペースが1つ入っております。

＞又、注文者住所の所において、郵便番号自体が記述されていないというパターンもあるのか否かという事も御教え願います。
いいえ。必ず入っております。

＞又、アップロードされた画像において、貼り付けられているデータは１件だけしかありませんが、
２件目以降は何行目から始まっていて、各件ごとのデータは、何行ごとの周期で入力されているのでしょうか？

各データにより行数が違うので１件1件A1セルに貼り付けております。

お時間をさいていただきありがとうございます。よろしくお願いいたします。

回答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列は空白でお願いいたします。

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

回答No.6

kagakusuki

回答No.5です。

　済みません、前の回答で提示させて頂いたマクロにおいて、「郵便番号が記入されておらず、尚且つ住所・番地の途中に空欄が入力されていた場合」において、F列に住所の一部が表示されないというバグが見つかりましたので、修正版を作りました。

Sub Macro()

Dim i, ra, rb, c1, c2, c3 As Long
Dim s1, s2, s3, s(5) As String

ra = 1: rb = 1
Do While Application.WorksheetFunction. _
CountIf(Range("A" & ra & ":A" & Rows.Count), "*?【*?】")
ra = ra - 1 + Application.WorksheetFunction. _
Match("*?【*?】", Range("A" & ra & ":A" & Rows.Count), 0)
s1 = Range("A" & ra).Value & ""
s2 = Range("A" & ra + 1).Value & ""
c1 = InStr(s1, "【")
c2 = InStr(Left(s2, 5), "-")
c3 = InStr(Replace(s2, "　", " "), " ")
s(0) = Left(s1, c1 - 1)
s(1) = s(0)
s(2) = Replace(Mid(s1, c1 + 1), "】", "")
s3 = ""
If c2 > 3 And c3 > c2 Then _
s3 = Replace(Replace(Left(s2, c3 - 1), "〒", ""), "-", "")
If s3 = "" Then c3 = 0
s(3) = ""
If IsNumeric(s3) Then s(3) = Format(s3, "000-0000")
s(4) = Trim(Mid(s2, c3 + 1))
For i = 0 To 4
Range("B" & rb).Offset(0, i).Value = s(i)
Next i
ra = ra + 1
rb = rb + 1
Loop
Range("B" & rb & ":F" & Rows.Count).ClearContents

End Sub

お礼

おはようございます。
No.5様の通りにやってみたのですが
このような結果になってしまいました。

Sub Macro()からEnd Subまでをコピー→sheet1右クリック→コードの表示→ペースト→
閉じる→サイトの情報画面をコピー→sheet1のA1にペースト→Alt F8→実行

私のやり方がおかしかったのでしょうか、、、？

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

せっかくお答えいただいたのに申し訳ございません。

補足

何度もお答えいただきありがとうございます。
朝から、まずはNO3様のご回答に対応しようと頑張っておりましたが
kagakusuki様のご回答までたどり着けずの状態です。

今しばらくお待ちいただけたらと思います。

又、NO3様のご回答に補足をさせていただきましたので
よければご覧いただけたらと思います。

回答No.5

kagakusuki

「山田　太郎【やまだ　たろう】」の次の名前がA3セルに入力されているのか、それとも1行空けてA4セルに入力されているのか、はたまた、2行以上も空けた行に入力されているのか、という条件が不明ですので、「□□□□【○○○○○】」という形式の文字列が入力されているセルが、何行目にあるのかという事を基準として処理を行う様にしたマクロです。
　ですから、前のデータの住所と後のデータの名前との間を空ける間隔が途中で変わってしまっていたとしても正常に動作致します。
　但し、「山田　太郎【やまだ　たろう】」と「〒123-4567　東京都～」の間が空いている様な場合には対応しておりません。
　それから、もしも郵便記号「〒」が入力されていなかった場合でも、番号の途中に半角の「-」が挟まっていて、尚且つ、郵便番号と住所の間には、空白スペース(全角、半角のどちらでも可)が入っているのであれば、郵便番号を正しく抽出する事が出来ます。
　又、郵便番号を入力し忘れている箇所があった場合には、E列を空欄とした上で、F列に住所が表示されます。
　又、郵便番号の所に入力されている文字列が、例えば「〒01A-9999」等の様に、数字に変換出来ない様な番号が入力されていた場合にも、E列を空欄とした上で、F列に住所が表示されます。

Sub Macro1()

Dim i, ra, rb, c1, c2, c3 As Long
Dim s1, s2, s3, s4, s(5) As String

ra = 1: rb = 1
Do While Application.WorksheetFunction. _
CountIf(Range("A" & ra & ":A" & Rows.Count), "*?【*?】")
ra = ra - 1 + Application.WorksheetFunction. _
Match("*?【*?】", Range("A" & ra & ":A" & Rows.Count), 0)
s1 = Range("A" & ra).Value & ""
s2 = Range("A" & ra + 1).Value & ""
c1 = InStr(s1, "【")
c2 = InStr(s2 & "-", "-")
c3 = InStr(Replace(s2, "　", " "), " ")
s(0) = Left(s1, c1 - 1)
s(1) = s(0)
s(2) = Replace(Mid(s1, c1 + 1), "】", "")
s3 = Replace(Left(s2, c2 - 1), "〒", "")
s4 = ""
If c3 > 0 Then s4 = Mid(Left(s2, c3 - 1), c2 + 1)
s(3) = ""
If IsNumeric(s3) And IsNumeric(s4) Then s(3) = s3 & "-" & s4
s(4) = Mid(s2, c3 + 1)
For i = 0 To 4
Range("B" & rb).Offset(0, i).Value = s(i)
Next i
ra = ra + 1
rb = rb + 1
Loop
Range("B" & rb & ":F" & Rows.Count).ClearContents

End Sub

回答No.4

tom04

Mp.3です。

＞でも、実際に自分のやりたい事に置き換えると
＞エラーになってしまいます。

というコトですので、無意味かもしれませんが、前回のコードは無意味なループをしていましたので
少々時間を要したと思います。

同様の条件で↓のコードに変更してみてください。
尚、ご自身でやりたいコトに置き換えるお役に立つかもしれませんので、
コードの前提条件を載せておきます。

（1）A2（偶数行）は必ず【　と　】が含まれている。
（2）氏名の次はスペースがなくすぐに　【　がある。
（3）A3（奇数行）は　〒　から始まりすぐにハイフンを含む7桁郵便番号である。
（4）A3（奇数行）は郵便番号の次はスペース（半角・もしくは全角）があり、その後は住所となっている。

以上の規則性でコードを書いています。

Sub Sample2() 'この行から
Dim i As Long, startStr As Long, endStr As Long, cnt As Long, str As String
On Error Resume Next
Application.ScreenUpdating = False
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row Step 2
startStr = InStr(Cells(i, "A"), "【")
endStr = InStr(Cells(i, "A"), "】")
cnt = cnt + 1
Cells(cnt, "B").Resize(, 2) = Left(Cells(i, "A"), startStr - 1)
Cells(cnt, "D") = Mid(Cells(i, "A"), startStr + 1, endStr - startStr - 1)
Cells(cnt, "E") = Mid(Cells(i + 1, "A"), 2, 8)
Cells(cnt, "F") = Mid(Cells(i + 1, "A"), InStr(StrConv(Cells(i + 1, "A"), vbNarrow), " ") + 1, Len(Cells(i + 1, "A")))
Next i
ActiveSheet.Columns.AutoFit
Application.ScreenUpdating = True
End Sub 'この行まで

※　少しは時間短縮ができるかもしれません。m(_ _)m

補足

こんにちは。再度ご回答いただきまして誠にありがとうございます。
お返事が遅れ申し訳ございません。朝から四苦八苦しておりました。
単純に入れ替えて出来ると思っておりましたが、私の考えがとても甘かった様で
これはやり方をお聞きしても、自分のやりたい事には
置き換える事が絶対に出来ないと思いましたので、
大変申し訳ございませんが１から説明させていただきます。
やりたい事はネットショッピングでの作業です。
大まかな説明は画像のリンクを貼るの見ていただきたいのですが、
http://www.fastpic.jp/users.php?act=gallery
ネットの画面をコピーして【画像（1）】http://www.fastpic.jp/images.php?file=3812557730.jpg
エクセル（2）に貼り【画像（2）】http://www.fastpic.jp/images.php?file=8222410222.jpg
いらない情報を削除して並びを変え【画像（3）】http://www.fastpic.jp/images.php?file=8398550021.jpg
それをエクセル（1）に貼りたい。【画像（4）】http://www.fastpic.jp/images.php?file=2006659237.jpg
エクセル（1）に貼り終った状態は【画像（5）】です。http://www.fastpic.jp/images.php?file=0278749892.jpg
ネットショッピングの注文情報をエクセルに移しCSVに保存して、
そのネットショッピングのシステムにアップロードしたいのですが
（アップロードするのエクセルはエクセル（１）とします。）【画像（5）】の状態

注文情報はシステムのネット上にしかないので、
まず画面をコピーしてエクセルに貼り付けます。
（それを貼り付けるのはエクセル（2）とします。）

ですが、アップロードする為のエクセル（１）【画像（4）】は書式が決まっておりますので
画面から貼り付けた状態のままではアップロードが出来ません。

ですので、画面からコピーした情報を、一旦エクセル（２）【画像（2）】に貼り付け、
情報の並び方をエクセル（１）と同様にしてからそれをコピーし
エクセル（１）に貼り付けております。

注文情報の画面は【画像（1）】の様に１件ずつしか見る事ができませんので
まとめてコピペが出来ません。

件数が少ないと、この作業も問題ないのですが
一日に１００件を越す事もあるので大変です。

【画像（1）】をご覧下さい。
赤く囲まれた部分をコピーして
エクセル（２）のA１のセルにペーストします。

ペーストした時のエクセル（２）の状態は【画像（2）】をご覧下さい。

ペーストした時によって違うのですが、
ネット画面の項目の紫の部分がエクセルのパターンとして紫になっている場合と
最初から色なしになっている場合があります。
それと、罫線も付いている時と付いていない時がありますが
毎回、コピーペーストしかしていませんがなぜ違うのかわかりません。
【画像（2）】は色も罫線無い場合のものです。

エクセル（２）にペーストした時に
項目が書かれている紫の部分（注文番号、注文日時、注文者情報、注文者住所、注文者電話番号）がAの列になりますがこの部分はいらないのでA列を選択して削除します。

以下、項目の上から説明させていただきます。

◆受注番号◆
半角で６桁ハイフン８桁ハイフン１０桁の数字です。
基本は数字とハイフンのみですが、数字の右側に
【スマートフォン】【タブレット】【モバイル】【ポイント】のどれか１つが付いている時と
画像の様に２つ付いている事があります。３つ以上付いているのは無いと思います。

必要なのは数字とハイフンのみで【スマートフォン】【タブレット】【モバイル】【ポイント】が
付いている場合は取りたいです。

付いている時は数字の終わりと【　の間に半角のスペースが入っておりますが
アップロードの際にスペースは不要です。

】と【　の間にはスペースはありません。

【　】が付いていない時は数字の最後にはスペースも何も付いておりません。
付いている時も　】の右側にはスペースはありません。

【スマートフォン】【タブレット】【モバイル】【ポイント】以外には見た事はありませんが
この先、他に何か付いてくる事があるかもしれません。

◆注文日時◆
必要ないので行ごと削除します。

◆注文者情報◆
名前[ナマエ]とメールアドレスと性別、生年月日が入っております。

このセルをセルの書式設定で見ると
配置→文字の制御で

折り返して全体を表示するにはチェックが入っておりますが、
文字は折り返しはしたくないのでチェックを外します。

セルを結合するは反転しております。
チェックを外すと注文者情報の

・名前[ナマエ]
・メールアドレス
・性別、生年月日がそれぞれ３つのセルに別れます。

メールアドレス、生年月日の情報は必要ないので行ごと削除します。

・名前[ナマエ]　かっこの種類はこれです。→　[]
・漢字と[の間には半角スペースが入っております。
・漢字もフリガナも苗字と名前の間のスペースは半角です。

注文者情報と書かれた項目の横に？のマーク黄色の○で囲みました。）も付いてしまうので
オブジェクトにしてから削除してます。

外国人の場合は漢字の部分が英語だったり、苗字と名前の間にスペースがなかったり
フリガナもない場合もあります。
フリガナもない場合は[]自体がありません。

このケースは稀ですので手入力をしようと思います。

◆注文者住所◆
〒マークはいりません。
〒マークと数字の間に半角のスペースあり。
数字の最後と住所の始めに半角のスペースあり。
どちらもスペースは不要です。

上記の作業をするとエクセル（２）のセルは

セルA1　半角で６桁ハイフン８桁ハイフン１０桁の受注番号
セルA2　名前 [ナマエ]の注文者氏名
セルA3　〒 000-0000 都道府県からの住所
セルA4　電話番号

が残ります。そこから【画像（3）】の状態にします。

【画像（3）】の行をコピーして
エクセル（1）にペーストして【画像（5）】の状態にします。

A2→　６桁ハイフン８桁ハイフン１０桁の半角受注番号のみ。
B2→　注文者氏名の漢字部分の苗字と名前（苗字と名前の間には半角スペースを入れる。）
※Bの列の見出しに「商品名」と書かれているにもかかわらず、
　注文者氏名を入れますが間違っているわけではございません。
C2→　同じく注文者氏名の漢字部分の苗字と名前（苗字と名前の間には半角スペースを入れる。）
D2→　注文者氏名のカタカナ部分の苗字と名前のみ。（[　]はいらない。苗字と名前の間には半角スペースを入れる。）
E2→　注文者電話番号半角数字とハイフンのみ。
F2→　注文者郵便番号（〒マークなし７桁の半角数字とハイフンのみ。）
G2→　都道府県からの注文者住所。

ここまでの作業を作業（1）とさせていただきます。
セルH1～セルL1　送付先住所については以下で説明させていただきます。

次に画像（1）の下の方に緑で囲まれた部分がありますが、
こちらは上の住所と電話番号が違う場合にのみ、行う作業でこちらを作業（2）とさせていただきます。

緑で囲まれた部分の〒マークから電話番号の終わりまでをコピーしてエクセル（２）にペーストします。

郵便番号、住所、電話番号がそれぞれのセルに入ります。

〒マークは不必要。マークと数字の間には半角スペースありですが７桁の半角数字とハイフンのみ必要。
住所はスペースも何もないのでそのまま使えます。
電話番号は半角数字とハイフンのみ必要。　TEL： は必要ありません。： と数字の間には半角スペースあり。
TEL： 全角は半角かよくわかりません。そのままペーストしました。

こ入力したいセルと内容は以下の通りです。
H2→　何も入力しません。
I2→　何も入力しません。
J2→　送付先電話番号半角数字とハイフンのみ。
K2→　送付先郵便番号（〒マークなし７桁の半角数字とハイフンのみ。）
L2→　都道府県からの送付先住所。

そして、エクセル（１）へペーストして。
この繰り返しです。

【画像（5）】では一件しか情報が入っていませんが
この繰り返し行って下にどんどん入力して行きたいです。
出来ればボタンでポチっとで終わってくれるととっても嬉しいです。

説明不足があるかもしれませんが、どうぞ宜しくお願いいたします。
エクセル（1）と（2）は別のエクセルデータです。
別にしている理由はエクセル（1）のデータがおかしな事になるのが怖いからです。

＞（1）A2（偶数行）は必ず【　と　】が含まれている。
はい。名前 [ナマエ]　で入力されており苗字と名前の間には半角スペースが入っております。
＞（2）氏名の次はスペースがなくすぐに　【　がある。
いいえ。半角スペースは１つ入っております。
＞（3）A3（奇数行）は　〒　から始まりすぐにハイフンを含む7桁郵便番号である。
〒　から始まっております。〒の右に半角スペース１つあり。ハイフンを含む7桁郵便番号であります。

＞（4）A3（奇数行）は郵便番号の次はスペース（半角・もしくは全角）があり、その後は住所となっている。
数字の最後と住所の始めに半角のスペース１つあり。
スペースのあとは都道府県から始まる住所です

長くなりましたがお願いいたします。

回答No.3

tom04

こんにちは！
VBAでの一例です。

前提条件として、データはA2セルからあり、一人につき2行使用しているとします。

シートモジュールですので、
画面左下の操作したいSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペースト　→　Excel画面に戻り、マクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim i As Long, startStr As Long, endStr As Long, k As Long, cnt As Long, str As String
On Error Resume Next
Application.ScreenUpdating = False
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row Step 2
cnt = cnt + 1
Cells(cnt, "B").Resize(, 2) = Left(Cells(i, "A"), InStr(Cells(i, "A"), "【") - 1)
For k = 1 To Len(Cells(i, "A"))
str = Mid(Cells(i, "A"), k, 1)
If str = "【" Then
startStr = k + 1
ElseIf str = "】" Then
endStr = k
End If
Next k
Cells(cnt, "D") = Mid(Cells(i, "A"), startStr, endStr - startStr)
Cells(cnt, "E") = Mid(Cells(i + 1, "A"), 2, 8)
Cells(cnt, "F") = Mid(Cells(i + 1, "A"), InStr(StrConv(Cells(i + 1, "A"), vbNarrow), " ") + 1, Len(Cells(i + 1, "A")))
Next i
ActiveSheet.Columns.AutoFit
Application.ScreenUpdating = True
End Sub 'この行まで

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

補足

ありがとうございます！
すごいです！その通りやってみましたら出来ました！

でも、実際に自分のやりたい事に置き換えると
エラーになってしまいます。

明日再度チャレンジしてみます！

回答No.2

noname#204879

マクロでないので別解です。
B1: =LEFT(A2,FIND("　",A2)-1)
C1: =MID(A2,FIND("　",A2)+1,FIND("【",A2)-FIND("　",A2)-1)
D1: =MID(A2,FIND("【",A2)+1,FIND("】",A2)-FIND("【",A2)-1)
E1: =MID(A3,2,FIND("　",A3)-2)
F1: =MID(A3,FIND("　",A3)+1,99)

お礼

ありがとうございます。

補足ですが
出来上がったデータをさらにコピーして
他のエクセルデータに貼り付けるので
関数が入っていると困るのです。

説明不足で申し訳ございません。

補足

ご回答いただきまして誠にありがとうございます。
教えてただいた回答でやってみました。

私の説明が悪かったようで
B１とC１はどちらも　山田　太郎　にしたかったのです。

あと
膨大なデータを短時間で１件1件並べ替えたいので
マクロを希望いたしました。

この関数を使ってマクロを組めるのでしょうか？
教えていただけたらと思います。

よろしくお願いいたします。

回答No.1

ohkinokomushi

マクロでなければならない事情があるなら別ですが、

１．データを全選択し、
　　データ-文字区切りで区切り文字に"【"を指定して実行
２．置換で"】"を削除

の手順を踏めば、後はマクロで処理するほどのことではないように思います。

補足

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

膨大なデータを短時間で１件1件並べ替えたいので
マクロを希望いたしました。