エクセルで、文字列から文字を取り出す自動マクロを教えてください。

質問

住所の入った、エクセルのファイルを頂くのですが、Ｃ２せるから、Ｃ５０程度のセルまでに
「〒１２３－４５６７兵庫県○○市○○３－４－５」と
一つのセルに入っています。
これをマクロで、Ｃ列の前に、一列挿入して、自動的に、〒番号の部分を切り取って、貼り付けるという
操作を、マクロでくみたいのです。
データは毎週貰うのですが、件数は５件～５０件程度までと幅はあります。データは２行目から連続して並んでいます。「列を挿入して」「LEFT関数で取り出すという関数をＣ２に入力」「数式をデータが終わるところまでコピー」「元のデータから〒番号を消去」というマクロを組みたいのです。お手数ですが、初心者にでも分かるようにマクロを教えて頂けませんでしょうか？

回答No.7

KenKen_SP · ベストアンサー

#6 です。

あまりスマートな方法ではありませんが。

#6 で補足いただけなかったのですが、住所はC列かD列か、、というのは1シート内
では統一されているものとします。それを Find で探しています。

Option Explicit

Sub Sample()

　　Dim lngROWNUM As Long
　　Dim lngCOLNUM As Long
　　Dim ADDRESS_C As Range
　　Dim i　　　　 As Long
　　Dim strDATA　 As String
　　Dim lngANSWER As Long

　　'住所の列を探します
　　Set ADDRESS_C = Cells.Find( _
　　　　What:="〒???-????*", _
　　　　LookIn:=xlValues, _
　　　　LookAt:=xlWhole, _
　　　　MatchCase:=False, _
　　　　MatchByte:=False)
　　If ADDRESS_C Is Nothing Then
　　　　MsgBox "データがありません", vbCritical
　　　　Exit Sub
　　End If
　　lngCOLNUM = ADDRESS_C.Column
　　Set ADDRESS_C = Nothing

　　'最終行番号取得
　　lngROWNUM = Cells(65536, lngCOLNUM).End(xlUp).Row
　　If lngROWNUM = 1 Then
　　　　MsgBox "データがありません", vbCritical
　　　　Exit Sub
　　End If

　　'画面描写停止
　　Application.ScreenUpdating = False

　　'郵便番号と住所の2列を挿入
　　Columns(lngCOLNUM + 1).Insert
　　Columns(lngCOLNUM + 1).Insert

　　'2行目から最終行までループ処理
　　For i = 2 To lngROWNUM
　　　　strDATA = Cells(i, lngCOLNUM).Text
　　　　If StrConv(strDATA, vbNarrow) Like "〒###-####*" Then
　　　　　　'郵便番号切り出し（〒マークはカット=2文字目から8文字）
　　　　　　Cells(i, lngCOLNUM + 1).Value = _
　　　　　　StrConv(Mid$(strDATA, 2, 8), vbNarrow)
　　　　　　'住所切り出し(10文字目以降）
　　　　　　Cells(i, lngCOLNUM + 2).Value = _
　　　　　　Mid$(strDATA, 10)
　　　　End If
　　Next i

　　'列幅調整・見出し
　　Columns(lngCOLNUM + 1).AutoFit
　　Columns(lngCOLNUM + 2).AutoFit
　　Cells(1, lngCOLNUM + 1).Value = "郵便番号"
　　Cells(1, lngCOLNUM + 2).Value = "住所"

　　'画面描写停止解除
　　Application.ScreenUpdating = True

　　'削除確認
　　Columns(lngCOLNUM).Select
　　lngANSWER = MsgBox( _
　　　　Prompt:="郵便番号と住所を分離しました。" & vbCrLf & vbCrLf & _
　　　　　　　　"分離前データを削除しますか？", _
　　　　Buttons:=vbQuestion Or vbYesNo Or vbDefaultButton2, _
　　　　Title:="削除確認")
　　If lngANSWER = vbYes Then
　　　　'元データの削除
　　　　Selection.Delete
　　End If

End Sub

お礼

ありがとうございました。

私の質問形式がつたない状態で、いろいろとありがとうございました。

想像通りのマクロです。

助かりました。

ほんとに感謝しています。