[VBA] InStrRevとLikeの組合せ

質問

こちらの識者の方々にはいつもお世話になっています。
VBAの質問です。

環境は下記になります。
OS=windowsXP SP3
Office=Excel2003(11.8347.8403) SP3

先日、
http://okwave.jp/qa/q8321600.html
で質問した内容なのですが、解決したと思ったらまだ未解決のため、再度質問いたします。

A列に住所のデータがあるのですが、形式がちょっと特殊で、
A1 千代田区千代田1-1-1-301千代田マンション１号棟
A2 千代田区千代田2-3-4
というな形になっています。(A1,A2はセル番地表示で、その文字列がセルにあるわけではありません)

並び順が、市名（区名）・町名・丁目・番地・号地・部屋番号・物件名となっています。
データの定義は、丁目・番地・号地・部屋番号については半角数字・市名（区名）・町名・物件名は数字やアルファベットを含むものであっても全角であることは担保されております。

戸建てであればいいのですが、集合住宅の場合、物件名と部屋番号が入れ替わってしまっています。
これを、できればA列には住所、B列には物件名・（全角スペース）・部屋番号とわけたいのです。
　　A　　　　　　　　　　　B
1　千代田区千代田1-1-1　　千代田マンション１号棟　301
2　千代田区千代田2-3-4

という内容で、ご回答いただいた

Sub SplitAddresses()
　　Dim i As Long, n As Integer, pos1 As Integer, pos2 As Integer, pos3 As Integer
　　For i = 1 To Cells(Rows.Count, "a").End(xlUp).Row
　　　　With Cells(i, "a")
　　　　　　For n = 0 To 9
　　　　　　　　pos1 = InStrRev(.Value, n)
　　　　　　　　If pos2 < pos1 Then pos2 = pos1
　　　　　　Next n
　　　　　　Cells(i, "b").Value = Right$(.Value, Len(.Value) - pos2)
　　　　　　.Value = Left$(.Value, pos2)
　　　　　　pos2 = 0
　　　　　　pos3 = InStrRev(.Value, "-")
　　　　　　If pos3 And Cells(i, "b").Value <> "" Then
　　　　　　　　Cells(i, "b").Value = Cells(i, "b").Value & "　" & Right$(.Value, Len(.Value) - pos3)
　　　　　　　　.Value = Left$(.Value, pos3 - 1)
　　　　　　End If
　　　　End With
　　Next i
　　Columns("a:b").AutoFit
End Sub

というコードでうまくいくと思ったのですが、
千代田区千代田1-2-3-4F千代田マンション１号棟
千代田区千代田1-1-1-A千代田マンション１号棟
といったデータも存在し、For n = 0 To 9ではまかなえないことがわかりました。
（数字の部屋番号だけではなく、4FやAなど、アルファベットの部屋番号が存在するということです）
数字だけではなく、半角英数字を末尾から検査し、その文字列がある位置を割り出す必要があるのですが、InStrRev関数とLike演算子を組み合わせて、返り値をpos1に代入しようと思ったもののうまくいきません。

ひとまず、返り値の確認のため、下記のようなコードを書きましたが、
Cells(1, 2) = InStrRev(Cells(1, 1), Like "*[0-z]*")
というコードは通らず、
Cells(1, 2) = InStrRev(Cells(1, 1), Cells(1, 1) Like "*[0-z]*")
というコードは返り値が0になってしまいます。

上記のような場合、どのようなコードが適していますでしょうか。
質問に不備不足等ございましたらご指摘ください。
ご面倒お掛けしますがよろしくお願いします。

回答No.2

WindFaller · ベストアンサー

InStreRevというのは、後ろから文字を探して、前から、その場所の文字数を出すというものですから、ご質問のようなコードは使えません。ご質問は詳しく読んでいないまま、直感的に書いてしまいました。

本来は、元のコードから直したほうがよい、というのは分かっているのですが、私の集中力がないので、汎用性のある「正規表現」にしてしまいました。条件によって、直さなくてはならない場合は、こちらの方が早いです。ただし、スピードは、元のコードを直したもののほうが、処理スピードは速いです。

私は、長い間のブランクがあるので、間違いがあればご容赦願います。以下の程度が、今は精一杯です。
なお、以下のコードは、単に、[正規表現のパターン]を切り替えれば、だいたいの要求には応えられるはずです。

>千代田区千代田1-2-3-4F千代田マンション１号棟
単純に、Fと千代田の間で切るわけですよね。でも、「千代田マンション」のところは、漢字じゃなくて、ひらがな・カタカナ・全角英字もあるのかな？いろんなトライアンドエラーをしてみないと、分かりません。

例：千代田区千代田1-1-1-301Aアシダマンション１号棟

"\w([ 　一-龠ぁ-ヶＡ-ｚ].+)"
なお、"["の次の文字は、半角スペース(1)、次が全角スペース(1)ですから、もし、コピペの段階で落ちたら、入れなおしてください。その後は全角文字です。「一-龠」は、ユニコードをほぼ網羅しています。ただし、文字検索としては、大雑把になっています。

'//
Sub Test1()
　Dim c As Range
　Dim buf As String
　Dim Matches As Object
　Dim i As Long
　With CreateObject("VBScript.RegExp")
　　.Global = False
　　.Pattern = "\w([ 　一-龠ぁ-ヶＡ-ｚ].+)" 'ここのパターンを書き換えれば汎用
　　For Each c In Range("A1", Cells(Rows.Count, 1).End(xlUp))
　　　buf = Trim(c.Value)
　　　Set Matches = .Execute(buf)
　　　If Matches.Count > 0 Then
　　　　i = Matches(0).FirstIndex
　　　　c.Value = Left(buf, i + 1)
　　　　c.Offset(, 1).Value = Trim(Matches(0).SubMatches(0))
　　　End If
　　Next c
　End With
　Columns("A:B").AutoFit
End Sub

'//

お礼

ありがとうございます。
正規表現は使ったことがないのですが、自分なりに調べてコメントをつけてみました。
不備等あればご指摘願います。
（変数cはRngに変更しました。すみません。しかもお礼欄では読みづらいです。御手数ですがVBEに貼り付けて参照いただければ見やすくなると思います。）

　Dim Rng As Range
　Dim buf As String
　Dim Matches As Object
　Dim i As Long

　With CreateObject("VBScript.RegExp")
　　.Global = False
　　.Pattern = "\w([ 　一-龠々ぁ-ヶＡ-ｚ].+)" 'JIS X 0208 の漢字、ひらがな、全角カタカナ、全角アルファベット
　　For Each Rng In Range("A1", Cells(Rows.Count, 1).End(xlUp)) 'A1からA列EndRowまでループ
　　　buf = Trim(Rng.Value) 'セルの文字列から先頭と末尾のスペースを削除し、bufに取り込み（Trimは念のため？）
　　　Set Matches = .Execute(buf) 'bufのマッチング結果をMatchesコレクションへ渡す
　　　If Matches.Count > 0 Then 'マッチング成功なら
　　　　i = Matches(0).FirstIndex '最初にマッチング成功した位置をiに取り込み？
　　　　Rng.Value = Left(buf, i + 1) '
　　　　Rng.Offset(0, 1).Value = Trim(Matches(0).SubMatches(0))
　　　End If
　　Next Rng
　End With
Columns("A:B").AutoFit

End Sub

一つ不明なのが、文字列"千代田区千代田1-2-3-4F千代田マンション１号棟"に対し、正規表現を使用し、一-龠々ぁ-ヶＡ-ｚの位置を返すというところから処理が始まると思うのですが、この処理で"千代田区"の"千"がMatches(0)に渡されない理由がわかりません。
一つ仮定が成り立つとすれば、"["の後の半角スペースで、「何かしらの半角文字の後の一-龠々ぁ-ヶＡ-ｚを検査する」という意味になるのでしょうか？
しかし、i = Matches(0).FirstIndex の部分を見ると、文字を0から起算して最後の半角英数字の位置が返っているような気がします。それを.Patternにて表現しているのだと思うのですが、
自分なりに調べてみたものの、\wの意味などは理解できたのですが、"["の後の半角スペースと全角スペースについては理解に至りませんでした（探すことができませんでした）

>.Pattern = "\w([ 　一-龠々ぁ-ヶＡ-ｚ].+)"
>i = Matches(0).FirstIndex
の部分について、ご教示いただいてもよろしいでしょうか。

回答No.10

30246kiku

＃９です

ご質問内容の解釈を間違っていたようです。
>　うまくいっていたという事なので、必ずあるものと思いますが

物件名が付加されている＝物件名先頭には部屋番号が必ずある　ということですね
＃７では、「物件名先頭には部屋番号が必ずある」を見落としていました。

千代田区千代田1-1-1千代田宅
　→　千代田区千代田1-1-1　　千代田宅

という元々のデータはないという事になりますか
（個人宅とかの場合は、物件名自体が無い・・・）

それを踏まえ、＃７を書き換えてみました。
変数 iUm が増えただけですが・・・・

千代田区千代田1-1-1千代田マンション１号棟
千代田区千代田1-1-1-301千代田マンション１号棟
千代田区千代田1-1-301千代田マンション１号棟
千代田区千代田1-1--301千代田マンション１号棟

は、

千代田区千代田1-1　　　千代田マンション１号棟　1
千代田区千代田1-1-1　　千代田マンション１号棟　301
千代田区千代田1-1　　　千代田マンション１号棟　301
千代田区千代田1-1　　　千代田マンション１号棟　301

になります。（他の過剰解釈はそのままで）

Option Explicit

Public Sub test2()
　　Dim vAry(1) As Variant, v As Variant
　　Dim sS As String, sP As String
　　Dim iU As Long, iM As Long, iUm As Long
　　Dim i As Long, j As Long

　　For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
　　　　v = Split(Cells(i, 1).Value, "-")
　　　　iU = UBound(v)
　　　　If (iU > 0) Then
　　　　　　vAry(1) = Empty
　　　　　　iUm = 3
　　　　　　sS = v(iU)
　　　　　　For j = 1 To Len(sS)
　　　　　　　　If (Mid(sS, j, 1) Like "[!0-9A-Z]") Then
　　　　　　　　　　vAry(1) = Mid(sS, j)
　　　　　　　　　　v(iU) = Mid(sS, 1, j - 1)
　　　　　　　　　　If (iUm > iU) Then iUm = iU
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next
　　　　　　If (Not IsEmpty(vAry(1))) Then
　　　　　　　　iM = 0
　　　　　　　　sP = "　"
　　　　　　　　For j = 1 To iU
　　　　　　　　　　If (iM = 0) Then
　　　　　　　　　　　　If ((j >= iUm) Or (Len(v(j)) = 0) _
　　　　　　　　　　　　　　Or (v(j) Like "*[!0-9]*")) Then iM = j
　　　　　　　　　　End If
　　　　　　　　　　If ((iM > 0) And (Len(v(j)) > 0)) Then
　　　　　　　　　　　　vAry(1) = vAry(1) & sP & v(j)
　　　　　　　　　　　　sP = "-"
　　　　　　　　　　End If
　　　　　　　　Next
　　　　　　　　If (iM > 0) Then ReDim Preserve v(iM - 1)
　　　　　　　　vAry(0) = Join(v, "-")
　　　　　　　　Cells(i, 1).Resize(, 2) = vAry
　　　　　　End If
　　　　End If
　　Next
End Sub

お礼

ご回答ありがとうございます。
正規表現でしかできないのかと思っていましたが、like演算子で!0-9A-Zで数字とアルファベット以外の文字を割り出す方法ですね。
とても参考になりました！

回答No.9

30246kiku

＃７です

元々の「千代田区千代田1-2-3-4F千代田マンション１号棟」は、
どなたが入力されるのかわかりませんが、解釈パターンをもう少し紹介しておきます。

千代田区千代田1-1-1-301千代田マンション１号棟
千代田区千代田1-1-301千代田マンション１号棟
千代田区千代田1-1--301千代田マンション１号棟
千代田区千代田1-2-4F-403千代田マンション１号棟
千代田区千代田1-2-3-------千代田マンション
千代田区千代田1-2-3-------A-----405千代田マンション
千代田区千代田1-2-3-10-----------405千代田マンション
千代田区千代田1-2--10----405千代田マンション
千代田区千代田1-2------B----405-千代田マンション
千代田区千代田1-2-3-----A棟----角405-----千代田マンション
千代田区千代田1-2-B棟----4F---5千代田マンション

は、

千代田区千代田1-1-1　　　千代田マンション１号棟　301
千代田区千代田1-1-301　　千代田マンション１号棟
千代田区千代田1-1　　　　千代田マンション１号棟　301
千代田区千代田1-2　　　　千代田マンション１号棟　4F-403
千代田区千代田1-2-3　　　千代田マンション
千代田区千代田1-2-3　　　千代田マンション　A-405
千代田区千代田1-2-3　　　千代田マンション　10-405
千代田区千代田1-2　　　　千代田マンション　10-405
千代田区千代田1-2　　　　千代田マンション　B-405
千代田区千代田1-2-3　　　千代田マンション　A棟-角405
千代田区千代田1-2　　　　千代田マンション　B棟-4F-5

と、解釈しています。

※ 号地は必ずあるんでしょうか？
　うまくいっていたという事なので、必ずあるものと思いますが
　なければ -- と省略指定するとか

回答No.8

cj_mover

＃４、５、ｃｊです。追加レスです。

色々書いた中でもうひとつ、RegExp（VBScript正規表現）の置換機能をフル活用
したものを流れに任せて載せてみます。
Instr関数もLike演算子も主役じゃないので、本題からは逸れた
参考回答になってしまいますが、前回に比べれば実践寄りの内容で少しスッキリしています。
スペースやタブ文字への対応を強化した以外は＃５と全く同じ処理をします。
マッチングパターンは難しいけど、これさえ把握してしまえば、
応用や発展が易しくなります。
「号」の位置（２番目の"-"の直後）にくる数字について、３桁以上ならば
前回同様、自動的に「号」ではなく「棟階室」として処理します。
サンプルの１番と１３番、１１番と１２番、それぞれ出力パターンの違いは
「号」の位置の数字が３桁以上かどうか、に因ります。
.SubMatchesのItemの指定は、0 から
置換パターン文字列は、1 から
添え字がずれている点は、少しややこしいかも知れません。
　.SubMatches.Item(0)　「市区町村#丁-#番」　"$1"
　..Item(1)　「-#号」　"$2"
　..Item(2)　「#号」　"$3"
　..Item(3)　「棟階室」　"$4"
　..Item(4)　「物件名」　"$5"
という対応関係です。
「市区町村#丁-#番-#号-'棟階室''物件名'」
に対して、置換パターン文字列
"$1$2" & vbCr & "$5　$4"
を指定すると
「市区町村#丁-#番-#号◆'物件名'　'棟階室'」
のように並べ替えたり不要な文字記号を抜いたりできます。
vbCrは、MainAddressとSubAddressの境界として意味付けしています。

入力ミス等が無いとしても、完全に整形することは誰の手にも難しいです。
出来れば、セルを書き換えるのでなく、他のセルに出力して、
整形結果を検証・修正する仕組みを別途用意した方が発展的で好いかも、です。

（サンプルデータ変えました）

＝＝＝＝　テスト用サンプルデータ＝＝＝＝
市区町村3-1-99
市区町村3-2-99-101
市区町村3-3-99-101物件名
市区町村3-4-99物件名-101
市区町村3-5-99-A
市区町村3-6-99-A物件名
市区町村3-7-99-5F
市区町村3-8-99-5F物件名
市区町村3-9-99 5F 物件名
市区町村3-10-99F-5物件名
市区町村3-11-99F物件名
市区町村2-12-101ＥｓｔＰｒｏｐ
市区町村2-13-101
市区町村2-14 5F ＥｓｔＰｒｏｐ
市区町村2-15-N-101ＥｓｔＰｒｏｐ
市区町村2-16-S-101
市区町村2-17B1ＥｓｔＰｒｏｐ
市区町村2-18B1
市区町村2-19ＥｓｔＰｒｏｐ5F-1
市区町村2-20ＥｓｔＰｒｏｐ
市区町村2-21
市区町村22
（空白）
dummy24
25

＝＝＝＝　出力パターン（仮設定）＝＝＝＝
１□無処理
■市区町村3-2-99◆101■
■市区町村3-3-99◆物件名　101■
■市区町村3-4-99◆物件名-101■
■市区町村3-5-99◆A■
■市区町村3-6-99◆物件名　A■
■市区町村3-7-99◆5F■
■市区町村3-8-99◆物件名　5F■
■市区町村3-9-99◆物件名　5F■
■市区町村3-10-99◆物件名　F-5■
■市区町村3-11-99◆物件名　F■
■市区町村2-12◆ＥｓｔＰｒｏｐ　101■
■市区町村2-13◆101■
■市区町村2-14◆ＥｓｔＰｒｏｐ　5F■
■市区町村2-15◆ＥｓｔＰｒｏｐ　N-101■
■市区町村2-16◆S-101■
■市区町村2-17◆ＥｓｔＰｒｏｐ　B1■
■市区町村2-18◆B1■
■市区町村2-19◆ＥｓｔＰｒｏｐ5F-1■
■市区町村2-20◆ＥｓｔＰｒｏｐ■
21□無処理
22□無処理
23□無処理
24□無処理
25□無処理

' ' ＝＝＝＝　サンプルコード＝＝＝＝　'　RegExp.Replace　版

Sub Re8325724cj()
　　Dim oRegExp As Object　'　As VBScript_RegExp_55.RegExp
　　Dim colMatches As Object　'　As VBScript_RegExp_55.MatchCollection
　　Dim c As Range　'　単セル ループ用
　　Dim sTmpAddress As String　'　ソース住所→(RegExp.Replace)→「MainAddress & CarriageReturn & SubAddress」
　　Dim sReplacePTN As String　'　RegExp.Replace 置換パターン文字列

　　Set oRegExp = CreateObject("VBScript.RegExp")　'　= New VBScript_RegExp_55.RegExp
' ' ◆RegExp パターン文字列
' ' (市区町村#丁-#番)(-(#号))?[タブ半角スペース-全角スペース]*([半角英数-])*[タブ半角スペース-全角スペース]*(文字列*)
　　oRegExp.Pattern = "(\D+\d+-\d+)(-(\d+))?[\t\s\-　]*([\w\-]*)[\t\s\-　]*(.*)"

' ' セル範囲総当たり
　　For Each c In Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
' ' ソース住所
　　　　sTmpAddress = c.Value
' ' ソース住所が空でない場合だけ処理
　　　　If sTmpAddress <> "" Then
　　　　　　Set colMatches = oRegExp.Execute(sTmpAddress)　'　RegExp.MatchCollection
　　　　　　If colMatches.Count > 0 Then　'　マッチしたならば
' ' ■■開発用　↓　RegExpパターン検証用コード■■
'Dim i As Long
'Debug.Print sTmpAddress
'For i = 0 To colMatches(0).SubMatches.Count - 1
'Debug.Print "●"; colMatches(0).SubMatches(i);
'Next i
'Debug.Print
' ' ■■開発用　↑　RegExpパターン検証用コード■■
' ' ◆RegExp.Replace 置換パターン文字列　合成開始
　　　　　　　　With colMatches(0).SubMatches　'　RegExp.サブマッチ。パターンの()の中身に相当
　　　　　　　　　　Select Case Val(.Item(2))　'　「号」位置の数字を数値化して判別
　　　　　　　　　　Case 0　'　「0 ならば」 =　先頭が数字でない文字列ならば　=　空文字ならば
　　　　　　　　　　　　sReplacePTN = "$1" & vbCr & "$5"　'　「市区町村丁-番／全角文字以降」
　　　　　　　　　　Case Is > 99　'　「号」位置の先頭数字が３桁ならば→それは「号」ではないと看做す
　　　　　　　　　　　　If .Item(4) <> "" Then　'　「物件名」（丁番号以降の半角英数以外）があれば
　　　　　　　　　　　　　　sReplacePTN = "$1" & vbCr & "$5　$3"　'　「市区町村丁-番／物件名　棟階室」
　　　　　　　　　　　　Else
　　　　　　　　　　　　　　sReplacePTN = "$1" & vbCr & "$3"　'　「市区町村丁-番／棟階室」
　　　　　　　　　　　　End If
　　　　　　　　　　Case Else　'　「1 - 99ならば」
　　　　　　　　　　　　sReplacePTN = "$1$2" & vbCr & "$5"　'　「市区町村丁-番-号」
　　　　　　　　　　End Select

　　　　　　　　　　If .Item(3) <> "" And .Item(4) <> "" Then　'　「棟階室」「物件名」両方あるならば
　　　　　　　　　　　　sReplacePTN = sReplacePTN & "　" & "$4"　'　& 「　棟階室」
　　　　　　　　　　Else
　　　　　　　　　　　　sReplacePTN = sReplacePTN & "$4"　'　& 「棟階室」
　　　　　　　　　　End If
　　　　　　　　End With
' ' ◆RegExp.Replace 置換パターン文字列　合成終了。置換。
　　　　　　　　sTmpAddress = oRegExp.Replace(sTmpAddress, sReplacePTN)
' ' ◆２列分同時に出力。SubAddress が有る場合のみ。
　　　　　　　　If Right$(sTmpAddress, 1) <> vbCr Then c.Resize(, 2).Value = Split(sTmpAddress, vbCr)
　　　　　　End If
　　　　End If
　　Next
End Sub

お礼

ご回答ありがとうございます。
正規表現は本当に奥が深いですね。
正規表現だけで一冊本が出来ているのも頷けます。
そして、新しいサンプルもありがとうございます。
考えられる住所データがほぼ網羅されており、これでおそらく問題ないと思います。

debug.printってこうやって使うんですね。
今までイミディエイトウィンドウを表示していたものの使い方が分からず、全く使っていませんでした。
重ね重ね、ありがとうございます。

回答No.7

30246kiku

まだ締め切られていなかったので、解釈パターンを適当に多くしてみました。
解決済みだが他を試してみる・・・　面倒であればスルーしてください。

「-」区切りの「物件名」先頭を分割する部分は、半角で、0 ～ 9、A ～ Z の範囲とします。

千代田区千代田1-1-1千代田マンション１号棟
千代田区千代田1-1-1千代田マンション－１号棟
千代田区千代田1-1-1-301A千代田マンション１号棟
千代田区千代田1-1-1-301ＣＨＩＹＯ田マンション１号棟
千代田区千代田1-1-1-301a千代田マンション１号棟
千代田区千代田1-1--301千代田マンション１号棟
千代田区千代田1--1-301千代田マンション１号棟
千代田区千代田1-2-3-4F千代田マンション１号棟
千代田区千代田1-2-4F千代田マンション１号棟
千代田区千代田1-4F千代田マンション１号棟
千代田区千代田1-2-3-A-405千代田マンション
千代田区千代田1-2-3-4-506千代田マンション
千代田区千代田1-2-A-301千代田マンション
千代田区千代田1-B棟-506千代田マンション
千代田区千代田1-2-B棟-千代田マンション
千代田区千代田1-2千代田マンション１号棟
千代田区千代田1-2-千代田マンション１号棟
千代田区千代田1-2-3
千代田区千代田1-1-A-301
千代田区千代田2

は、

千代田区千代田1-1-1　　千代田マンション１号棟
千代田区千代田1-1-1　　千代田マンション－１号棟
千代田区千代田1-1-1　　千代田マンション１号棟　301A
千代田区千代田1-1-1　　ＣＨＩＹＯ田マンション１号棟　301
千代田区千代田1-1-1　　a千代田マンション１号棟　301
千代田区千代田1-1　　　千代田マンション１号棟　301
千代田区千代田1　　　　千代田マンション１号棟　1-301
千代田区千代田1-2-3　　千代田マンション１号棟　4F
千代田区千代田1-2　　　千代田マンション１号棟　4F
千代田区千代田1　　　　千代田マンション１号棟　4F
千代田区千代田1-2-3　　千代田マンション　A-405
千代田区千代田1-2-3　　千代田マンション　4-506
千代田区千代田1-2　　　千代田マンション　A-301
千代田区千代田1　　　　千代田マンション　B棟-506
千代田区千代田1-2　　　千代田マンション　B棟
千代田区千代田1-2　　　千代田マンション１号棟
千代田区千代田1-2　　　千代田マンション１号棟

となり、以下３つは何もしません。

千代田区千代田1-2-3
千代田区千代田1-1-A-301
千代田区千代田2

※ 間違って複数回実行しても、分割対象でなかったものへは何もしません
（分割対象は、最後の「-」以降に [!0-9A-Z] が存在したら）

※ 不都合あれば変更してください
　途中にスペースが入っている場合がある・・・　とか

※ ソコソコ動くと思いますが、処理性能はわかりません

Option Explicit

Public Sub test1()
　　Dim vAry(1) As Variant, v As Variant
　　Dim sS As String, sP As String
　　Dim iU As Long, iM As Long
　　Dim i As Long, j As Long

　　For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
　　　　v = Split(Cells(i, 1).Value, "-")
　　　　iU = UBound(v)
　　　　If (iU > 0) Then
　　　　　　vAry(1) = Empty
　　　　　　sS = v(iU)
　　　　　　For j = 1 To Len(sS)
　　　　　　　　If (Mid(sS, j, 1) Like "[!0-9A-Z]") Then
　　　　　　　　　　vAry(1) = Mid(sS, j)
　　　　　　　　　　v(iU) = Mid(sS, 1, j - 1)
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next
　　　　　　If (Not IsEmpty(vAry(1))) Then
　　　　　　　　iM = 0
　　　　　　　　sP = "　"　' 全角のスペース１個
　　　　　　　　For j = 1 To iU
　　　　　　　　　　If (iM = 0) Then
　　　　　　　　　　　　If ((j >= 3) Or (Len(v(j)) = 0) _
　　　　　　　　　　　　　　Or (v(j) Like "*[!0-9]*")) Then iM = j
　　　　　　　　　　End If
　　　　　　　　　　If ((iM > 0) And (Len(v(j)) > 0)) Then
　　　　　　　　　　　　vAry(1) = vAry(1) & sP & v(j)
　　　　　　　　　　　　sP = "-"
　　　　　　　　　　End If
　　　　　　　　Next
　　　　　　　　If (iM > 0) Then ReDim Preserve v(iM - 1)
　　　　　　　　vAry(0) = Join(v, "-")
　　　　　　　　Cells(i, 1).Resize(, 2) = vAry
　　　　　　End If
　　　　End If
　　Next
End Sub

回答No.6

WindFaller

#2の回答者です。
あまり、まともな返事になっていないかもしれませんが、返事をつけておきます。

"\w([ 　一-龠々ぁ-ヶＡ-ｚ].+)"
私が元に書いた範囲はあまり正確ではありませんが、「々」が必要なら、「ぁ」の代わりに、「、-ヶ」を入れれば文字数は少なくなるかもしれません。それは、任意で構いません。括弧やカギ括弧を住所にいれる人はいないでしょうけれども。

>文字列"千代田区千代田1-2-3-4F千代田マンション１号棟"に対し、……この処理で"千代田区"の"千"がMatches(0)に渡されない理由がわかりません。

\wは、英数（半角）の文字の後に、という意味ですから、全角は含まれません。住所の番地や記号は英数半角の文字という決まりだったように読んだからです。

>"["の後の半角スペースと全角スペースについては理解に至りませんでした（探すことができませんでした）

それは、サンプルの文字を見た時に、そう思ったからです。全角スペース・半角スペースが混在すると、感じたからです。全角・半角スペースの場合は、本来は定番のコードというものがありますが、今は、前回書いたように集中力のなさが原因で、深く考えていません。本来は、\bが使えれば、それに越したことはありませんが、確実性が乏しいのです。

>i = Matches(0).FirstIndex
パターンの該当した所の最初の文字の位置のつもりなのですが、最初が0ですので、1を足した、ということですが、これも、あまり考えていないのです。

ところで、
>変数cはRng

----------
余談：よけいなことですが、私は、c は、Cells の意味で使っています。カウンター変数なので、小文字にしています。私は、Rngは、Rangeオブジェクトで使っていました。いくぶんは、ローカル変数なので、myのプレフィックスをつけて、myRng とすることもあります。

sh =Sheet, c = Cells, wb = Workbook　……本来は、こういう時に、オブジェクトの変数は、省略形の名称はつけてはいけないというルールがあるのですが、それにも関わらず、こういう変数が使われるのは、VBを作り、MSを退職したC.シモニーさんや、そのチームが初期から使っていたらしいのです。まあ、どうでもよい話ですが……。

お礼

お礼が遅くなってすみません。
正規表現は本当に奥が深いですね。
これからも勉強を続け、是非マスターしたいと思います。

>余談：よけいなことですが、私は、c は、Cells の意味で使っています。カウンター変数なので、小文字にしています。私は、Rngは、Rangeオブジェクトで使っていました。いくぶんは、ローカル変数なので、myのプレフィックスをつけて、myRng とすることもあります。

なるほど、Cellsのcだったんですね。
実は少し前にWithステートメントの.を一つ忘れただけで3時間デバッグしたこともあり、短い変数名は見落としが怖いなと思ってRngにしました。
変数名の付け方は迷っていたところなので是非参考にさせていただきます。

>VBを作り、MSを退職したC.シモニーさんや、そのチームが初期から使っていたらしいのです。まあ、どうでもよい話ですが……。

どうでもよくないです！こういううんちくは大好きです！
チャールズ・シモニーさん、調べました。
史上5人目の民間宇宙旅行者だとか・・・
そして、あのハンガリアン記法を提唱した人だったんですね。
僕もかっこいいと思って一時期使っていたんですが、OfficeTANAKAのサイトでVBAでハンガリアン記法が不要みたいな記述があったのでやめてしまいました。
VBを作ったというのはすごいですね。
Option Base 1を指定していても、なぜArrayとSplitは添え字が0から始まるのか聞いてみたいです。

回答No.5

cj_mover

（２／２連投）

以下、標準モジュールです。

Sub Re8325724()
　　Dim c As Range
　　Dim sAddress As String
　　Dim sSubAddress As String

　　For Each c In Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
　　　　sAddress = c.Value
　　　　sSubAddress = fnSubAddress(sAddress)
　　　　If sSubAddress <> "" Then
　　　　　　c.Value = sAddress
　　　　　　c.Offset(, 1).Value = sSubAddress
　　　　End If
　　Next
End Sub

' ' /// 文字列を引数に
' ' 【「市区町村」「丁」-「番」-「号」】MainAddress
' ' と【それ以外】SubAddress
' ' とに分ける関数。
' ' SubAddress先頭に半角文字がある場合は
' ' SubAddressの後ろに全角スペースを挟んで後ろに移動
' ' 戻り値はSubAddress。
' ' MainAddressをByRef型でsAddressに返す。
Function fnSubAddress(ByRef sAddress As String) As String
　　Const Delimiter = "-"　　'　　住所の区切り文字"-"
　　Dim arrSrc() As String　　'　　住所を区切り文字"-"を基準に配列化
　　Dim sSubAddress As String　　'　　「市区町村」「丁」-「番」-「号」以外の住所
　　Dim nPos As Long　　'　　住所の区切り文字"-"が見つかる位置
　　Dim nBound As Long　　'　　MainAddressとSubAddressの区切り位置
　　Dim nDL As Long　　'　　フラグ。Main★Sub 区切り位置が"-"なら１
　　Dim nPW As Long　　'　　SubAddress内で最初に見つかる全角文字の位置

' ' ◆０「市区町村」【「丁」】-
　　nPos = InStr(sAddress, Delimiter)　　'　　１番めの"-"の位置
　　' ' 住所の区切り文字"-"が見つからないなら、何もしないで抜ける。
　　If nPos = 0 Then Exit Function

　　' ' 住所を区切り文字"-"を基準に配列化し、配列変数に格納。
　　arrSrc() = Split(sAddress, Delimiter)

' ' ■■MainAddressとSubAddressの区切り位置＝nBoundを決める

' ' ◆１「市区町村」「丁」-【「番」】-

　　' ' 「番」の位置にある文字列が数字として読めないならば
　　If Not IsNumeric(arrSrc(1)) Then
　　　　' ' Val()関数で先頭にあるであろう数字を数値化して、
　　　　' ' 先頭数字部分の文字長を採り、１番めの"-"の位置に加算
　　　　' ' したものをMain★Sub 区切り位置に指定。
　　　　nBound = nPos + Len(CStr(Val(arrSrc(1)))) + 1　　'　　Main★Sub 区切り位置
　　End If

' ' ◆２「市区町村」「丁」-「番」-【「号」or(「棟」or「階」or「部屋」)+(「棟」or「物件」)】

　　nPos = InStr(nPos + 1, sAddress, Delimiter)　　'　　２番めの"-"の位置
　　' ' ２番めの"-"が見つかるならば
　　If nPos > 0 Then
　　　　' ' Main★Sub 区切り位置が未確定ならば
　　　　If nBound = 0 Then
　　　　　　' ' 「号」の位置にある文字列が数字として読めるならば
　　　　　　If IsNumeric(arrSrc(2)) Then
　　　　　　　　' ' 「号」が３桁以上の数字ならば
　　　　　　　　If Val(arrSrc(2)) > 99 Then
　　　　　　　　　　' ' ２番めの"-"の位置をMain★Sub 区切り位置に指定。
　　　　　　　　　　nBound = nPos　　'　　Main★Sub 区切り位置
　　　　　　　　　　nDL = 1　　 '　　Main★Sub 区切り位置が"-"
　　　　　　　　Else　　'　　「号」が２桁以下の数字ならば
　　　　　　　　　　' ' ３番めの"-"の位置をMain★Sub 区切り位置に指定。
　　　　　　　　　　nBound = InStr(nPos + 1, sAddress, Delimiter)　　'　　Main★Sub 区切り位置
　　　　　　　　　　nDL = 1　　 '　　Main★Sub 区切り位置が"-"
　　　　　　　　End If
　　　　　　Else　　'　　「号」の位置にある文字列が数字として読めないならば
　　　　　　　　' ' Val()関数で先頭にあるかも知れない数字を数値化して、
　　　　　　　　Select Case Val(arrSrc(2))
　　　　　　　　Case 0, Is > 99　　 '　　先頭が数字でない場合、または、数字が３桁以上ならば
　　　　　　　　　　' ' ２番めの"-"の位置をMain★Sub 区切り位置に指定。
　　　　　　　　　　nBound = nPos　　'　　Main★Sub 区切り位置
　　　　　　　　　　nDL = 1　　 '　　Main★Sub 区切り位置が"-"
　　　　　　　　Case Is < 100　　'　　先頭が２桁以下の数字ならば
　　　　　　　　　　' ' Val()関数で先頭にあるかも知れない数字を数値化して、
　　　　　　　　　　' ' 先頭数字部分の文字長を採り、２番めの"-"の位置に加算
　　　　　　　　　　' ' したものをMain★Sub 区切り位置に指定。
　　　　　　　　　　nBound = nPos + Len(CStr(Val(arrSrc(2)))) + 1　　'　　Main★Sub 区切り位置
　　　　　　　　End Select
　　　　　　End If
　　　　End If
　　End If

' ' MainAddressとSubAddressの区切り位置が見つからないなら、何もしないで抜ける。
　　If nBound = 0 Then Exit Function

' ' ■■SubAddressを整形。「半角* + 全角*」 を 「全角* + "　" + 半角*」 に並べ替え。
' ' SubAddressを取得。
　　sSubAddress = Mid$(sAddress, nBound + nDL)
' ' SubAddressから半角スペースを削除。
　　If InStr(sSubAddress, " ") > 0 Then sSubAddress = Replace(sSubAddress, " ", "")
' ' SubAddress内で最初に見つかる全角文字の位置。
　　nPW = InstrWideChar1st(sSubAddress)
' ' SubAddressが半角で始まり、且、全角文字を含むならば、並べ替え。
　　If nPW > 1 Then sSubAddress = Mid$(sSubAddress, nPW) & "　" & Left$(sSubAddress, nPW - 1)
' ' SubAddressが数字として読める文字列ならば、プレフィクスで文字列を強制。
　　If IsNumeric(sSubAddress) Then sSubAddress = "'" & sSubAddress

' ' MainAddressを設定。ByRef型の変数 sAddress に返す。
　　sAddress = Left$(sAddress, nBound - 1)
' ' SubAddressを関数の戻り値として返す。
　　fnSubAddress = sSubAddress
End Function

' ' /// 文字列を引数に、最初に見つかる全角文字の位置、を返す関数。
' ' すべて半角なら、0 を返す。
Function InstrWideChar1st(ByVal sSrc As String) As Long
　　Dim nLen As Long
　　Dim i As Long
　　nLen = Len(sSrc)
　　For i = 1 To nLen
　　　　If Not Mid$(sSrc, i, 1) Like "[0-9A-Za-z-]" Then Exit For
'　　　　If Not Asc(Mid$(sSrc, i, 1)) > 0 Then Exit For
　　Next i
　　If i > nLen Then i = 0&
　　InstrWideChar1st = i
End Function

回答No.4

cj_mover

（１／２連投）
こんにちは。お邪魔します。

この課題は掘り下げると色々なこと考えだして結構大変ですね。
仕様の確定までに掛かる労力が全体の８割。といった感じでしょうか。
とりあえず動くものを書いて、カットアンドトライしながら仕様確定、
って感じでやるしかないでしょうから、質問が２回以上に分かれるのも妥当ですね。
しかし何ていうか、仕様を変える度に、
コードの基本設計から変えたくなる、不思議なテーマで、結構嵌ってしまいました。
q8321600の時も当初は正規表現でサクっと簡単にできた、と思ったら、
次から次、出てくる出てくる。
とりあえず、仕様確定のヒントになるようテスト用サンプルデータです。
→マークの行は、私が仮に設定した出力パターンです。

市区町村3-1-99-101教えてマンション１号棟
　　→■市区町村3-1-99◆教えてマンション１号棟　101■
市区町村3-2-99-5F教えてマンション１号棟
　　→■市区町村3-2-99◆教えてマンション１号棟　5F■
市区町村3-3-99-A教えてマンション１号棟
　　→■市区町村3-3-99◆教えてマンション１号棟　A■
市区町村3-4-99教えてマンション１号棟-101
　　→■市区町村3-4-99◆教えてマンション１号棟-101■
市区町村3-5-99F-5ＯＫステート
　　→■市区町村3-5-99◆ＯＫステート　F-5■
市区町村3-6-99Ａｎｓｗｅｒビル101
　　→■市区町村3-6-99◆Ａｎｓｗｅｒビル101■
市区町村3-7-99-101
　　→■市区町村3-7-99◆'101■
市区町村3-8-99
　　→■市区町村3-8-99◆■
市区町村3-9-99猫屋敷
　　→■市区町村3-9-99◆猫屋敷■
市区町村2-10-101桶愚タウン
　　→■市区町村2-10◆桶愚タウン　101■
市区町村2-11-101
　　→■市区町村2-11◆'101■
市区町村2-12-N-101優良ヒルズ
　　→■市区町村2-12◆優良ヒルズ　N-101■
市区町村2-13-S-101
　　→■市区町村2-13◆S-101■
市区町村2-14ＯＫステート5F-1
　　→■市区町村2-14◆ＯＫステート5F-1■
市区町村2-99猫屋敷
　　→■市区町村2-99◆猫屋敷■
市区町村2-101猫屋敷
　　→■市区町村2-101◆猫屋敷■
市区町村2-102
　　→■市区町村2-102◆■
（空白）
　　→■◆■
d
　　→■d◆■
1
　　→■1◆■

コード、というより説明コメントが厚量になってしまったので、投稿を２回に分けますが、
次の投稿で、上に挙げたような結果を返すように書いた
暫定コードを挙げてみます（仕上がってはいませんが機能はします）。
上に挙げたサンプルの中には、
"そんなのリストにないよ"とか"求める結果と違うよ"とか
過不足等はあると思います。
この回答の狙いは仕様確定のヒント、ですので、、、。

正規表現も使わず、ループも最低限にして、ベタに書きました。
MainAddressとSubAddressという風に分けて考えて
左から順番に見ていって区切り位置を決めています。
「号」の位置の先頭の数字について、
２桁以下なら「号」としてMainAddressに
３桁以上ならSubAddressの末尾に
というようにしてみました。
＃っつか、これがやりたくてこんなベタな書き方をしています。
「番」の位置の数字は必ず、「番」として扱います。

例示を増やしてみても、例外的な不正処理は出て来ますね。
物件名が半角英数とかだとSubAddressの整形はうまく行きませんし。
どこら辺で妥協点を見つけるか、ですけれど、
何となく感覚的に、多数をカバー出来そうと思える方法にしてみました。
その分、解り易さとか合理性とかは、あまり感じられないものになっている
とは思います。
実用には、とことん追求して完成させるのもあるかも知れませんが、
もう少し仕様を緩くしたものにする方が現実的な気はしています。

（次の投稿に続きます）

回答No.3

MarcoRossiItaly

質問文にお示しのコードを前回回答した者です。

実際のデータに当たると、やはり課題がいろいろ出てきますね。皆さんから別解が出ていると思いますが、一応、前回のコードを改造したバージョンも載せますね。

前回からの変更点は、「For n = ...」というのが 2 回出てくることです。Asc、Chr 関数というのを使うと、文字を文字コードと呼ばれる数値で扱うことができます。つまり Like 演算子とかを持ち出す必要はないということですね。

Sub SplitAddresses()
　　Dim i As Long, n As Integer, pos1 As Integer, pos2 As Integer, pos3 As Integer
　　For i = 1 To Cells(Rows.Count, "a").End(xlUp).Row
　　　　With Cells(i, "a")
　　　　　　For n = 0 To 9
　　　　　　　　pos1 = InStrRev(.Value, n)
　　　　　　　　If pos2 < pos1 Then pos2 = pos1
　　　　　　Next n
　　　　　　For n = Asc("A") To Asc("z")
　　　　　　　　pos1 = InStrRev(.Value, Chr(n))
　　　　　　　　If pos2 < pos1 Then pos2 = pos1
　　　　　　Next n
　　　　　　Cells(i, "b").Value = Right$(.Value, Len(.Value) - pos2)
　　　　　　.Value = Left$(.Value, pos2)
　　　　　　pos2 = 0
　　　　　　pos3 = InStrRev(.Value, "-")
　　　　　　If pos3 And Cells(i, "b").Value <> "" Then
　　　　　　　　Cells(i, "b").Value = Cells(i, "b").Value & "　" & Right$(.Value, Len(.Value) - pos3)
　　　　　　　　.Value = Left$(.Value, pos3 - 1)
　　　　　　End If
　　　　End With
　　Next i
　　Columns("a:b").AutoFit
End Sub

お礼

ご回答ありがとうございます。Asc、Chr関数は知りませんでした。
たしかにこれを使うとLike演算子を使用せずともA-zまでの文字列を扱うことができますね。
当然、問題のあった行については解決できました！
ありがとうございました。

回答No.1

mu2011

一例です。
ハイフン（半角）区切りの最終ブロックが５文字以上を部屋番号・物件名として分割してみました。

Sub sample()
Dim i As Long, j As Long, wk, wk1(), wk2, ch
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
wk = Split(Cells(i, 1), "-")
If Len(wk(UBound(wk))) > 5 Then
For j = 0 To UBound(wk) - 1
ReDim Preserve wk1(j)
wk1(j) = wk(j)
Next
Cells(i, 1) = Join(wk1, "-")
wk2 = wk(UBound(wk))
For j = 1 To Len(wk2)
If Mid(wk2, j, 1) Like "[0-9-A-z]" Then
ch = ch & Mid(wk2, j, 1)
Else
Exit For
End If
Next
Cells(i, 2) = Replace(wk2, ch, "") & "　" & ch
ch = ""
End If
Next
End Sub

お礼

ありがとうございます。
正規表現は使ったことがないのですが、自分なりに調べてコメントをつけてみました。
不備等あればご指摘願います。
（変数cはRngに変更しました。すみません。しかもお礼欄では読みづらいです。御手数ですがVBEに貼り付けて参照いただければ見やすくなると思います。）

　Dim Rng As Range
　Dim buf As String
　Dim Matches As Object
　Dim i As Long

　With CreateObject("VBScript.RegExp")
　　.Global = False
　　.Pattern = "\w([ 　一-龠々ぁ-ヶＡ-ｚ].+)" 'JIS X 0208 の漢字、ひらがな、全角カタカナ、全角アルファベット
　　For Each Rng In Range("A1", Cells(Rows.Count, 1).End(xlUp)) 'A1からA列EndRowまでループ
　　　buf = Trim(Rng.Value) 'セルの文字列から先頭と末尾のスペースを削除し、bufに取り込み（Trimは念のため？）
　　　Set Matches = .Execute(buf) 'bufのマッチング結果をMatchesコレクションへ渡す
　　　If Matches.Count > 0 Then 'マッチング成功なら
　　　　i = Matches(0).FirstIndex '最初にマッチング成功した位置をiに取り込み？
　　　　Rng.Value = Left(buf, i + 1) '
　　　　Rng.Offset(0, 1).Value = Trim(Matches(0).SubMatches(0))
　　　End If
　　Next Rng
　End With
Columns("A:B").AutoFit

End Sub

一つ不明なのが、文字列"千代田区千代田1-2-3-4F千代田マンション１号棟"に対し、正規表現を使用し、一-龠々ぁ-ヶＡ-ｚの位置を返すというところから処理が始まると思うのですが、この処理で"千代田区"の"千"がMatches(0)に渡されない理由がわかりません。
一つ仮定が成り立つとすれば、"["の後の半角スペースで、「何かしらの半角文字の後の一-龠々ぁ-ヶＡ-ｚを検査する」という意味になるのでしょうか？
しかし、i = Matches(0).FirstIndex の部分を見ると、文字を0から起算して最後の半角英数字の位置が返っているような気がします。それを.Patternにて表現しているのだと思うのですが、
自分なりに調べてみたものの、\wの意味などは理解できたのですが、"["の後の半角スペースと全角スペースについては理解に至りませんでした（探すことができませんでした）

>.Pattern = "\w([ 　一-龠々ぁ-ヶＡ-ｚ].+)"
>i = Matches(0).FirstIndex
の部分について、ご教示いただいてもよろしいでしょうか。

補足

すみません。番号を間違えてお礼してしまいました。
部屋番号は多くても4桁だろうと仮定し5文字以上の処理にしていただいたのですね。
しかも要望どおりLike演算子を使用したコードをご提示いただきありがとうございます。
全ては検査していませんが、問題のあった行については解決していました。ありがとうございました。