[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『住所を一文字ずつセルに分割して番地・号の桁揃え』（mayo）
お世話になります。マクロで処理したいひとつ目として、
例：
□□町1番地1
□□町1丁目1番1号
□□町10丁目10番10号−10号
のような住所の文字列を一文字ずつセルに分割したいと考えています。この分割に関しては過去ログ[[20090521230713]]?での質問内容と私の考えていることがほぼ同じでそのまま参考になりましたので、ここで提示されているichinose様のコードを使わせて頂きました。
ふたつ目に、今回扱う文字列が住所ですので、できれば丁目・番地・号の数字部分の桁数を揃えたいのです。丁目はxx丁目のように2桁、番・番地・号・部屋番号はxxxx番地のように4桁に統一したいと考えています。
過去ログ[[20090521230713]]?で提示されているichinose様のコードをそのまま実行しますと、
A B C D E F G H I J K L M N... 1 □ □ 町 1 番 地 1 2 □ □ 町 1 丁 目 1 番 1 号 3 □ □ 町 1 0 丁 目 1 0 番 1 0 号 − 1 0 号
のようになります。これを
A B C D E F G H I J K L M N... 1 □ □ 町 x x x 1 番 地 x x x 1 2 □ □ 町 x 1 丁 目 x x x 1 番 x x x 1 号 3 □ □ 町 1 0 丁 目 x x 1 0 番 x x 1 0 号 − x x x 1 0 号 4 □ □ 町 1 1 丁 目 x 1 0 0 番 x 1 0 0 号 − x x 1 0 0 号
のように数字部分の桁を揃えて、それぞれ丁目・番・号が全て同じ列に縦に並ぶようにしたいのです。この桁揃えについては過去ログ[[20080906092221]]にて同じような質問がされていました。
ただ、今回は住所を一文字ずつ分割していく課程で丁目や番地などの桁を自動で揃えたいのですが･･･このような事はマクロで可能でしょうか？
ichinose様のコードをベースに、過去ログ[[20080906092221]]の考え方を参考にして試していたのですが一向にうまくいきません。
私の望むような処理がマクロで可能であればどのように記述すれば可能になるのか、皆様のお知恵をお貸し頂ければと思います。
尚、Excelは2003です。
また、住所の文字列は全て上の例のような形式になっております。丁目・番地を省略した□□町1-1-1や□□町10丁目10-10-10といった形式のものはありません。分割したい住所の文字列には〜県〜市までは含まれず、全て町名から始まっています。
どうぞよろしくお願いいたします。
（mayo）
>1 □ □ 町 1 番 地 1 >2 □ □ 町 1 丁 目 1 番 1 号 >3 □ □ 町 1 0 丁 目 1 0 番 1 0 号 − 1 0 号
この程度のパターンと決まっているなら・・・、
'=======================================================================================
Sub main()
Dim rng As Range
With ActiveSheet
For Each rng In .Range("a1", .Cells(.Rows.Count, "a").End(xlUp))
rng.Value = edit_add(rng.Value)
Next
End With
Call 列挿入と文字分割(ActiveSheet)
End Sub
'========================================================================================
Function edit_add(ByVal add As Variant) As String
Dim myans As Variant
Dim g0 As Long
Dim g1 As Long
Dim edstr As Variant
Dim eddem As Variant
edstr = Array("丁目", "番地", "番", "号−", "号")
eddem = Array(2, 4, 4, 4, 4)
edit_add = ""
edit_add = Left(add, InStrRev(add, "町"))
add = Mid(add, InStrRev(add, "町") + 1)
For g1 = LBound(edstr) To UBound(edstr)
If Len(add) > 0 Then
g0 = InStr(add, edstr(g1))
If g0 > 0 Then
edit_add = edit_add & _
Format(Left(add, g0 - 1), _
String(eddem(g1), "@") & """" & edstr(g1) & """")
add = Mid(add, g0 + Len(edstr(g1)))
End If
Else
Exit For
End If
Next
If Len(add) > 0 Then
edit_add = edit_add & format(add, "@@@@")
End If
End Function
'======================================================================================
Sub 列挿入と文字分割(sht As Worksheet)
Dim rng As Range
Dim mlen As Long
Dim g0 As Long
With sht
Set rng = .Range("a1", .Cells(.Rows.Count, "a").End(xlUp))
mlen = Evaluate("max(len(" & rng.Address(, , , True) & "))")
If mlen > 0 Then
rng.Offset(0, 1).EntireColumn.Resize(, mlen).Insert
With rng.Offset(0, 1).Resize(, mlen)
.Formula = "=mid($a1,column()-1,1)"
.Value = .Value
End With
End If
End With
End Sub
考え方としては、Ａ列の番地関連文字列を先に桁揃えしてから、 文字分割を行っています。従って、Ａ列を書き換えていますので 困るなら、どこかにコピーをとっておいてください。
ichinose@本日地区の球技大会
-以降のデータは5ケタ？ですわなぁ。
-305号室などにも対応しとります。
列挿入、オートフィットはご随意に。
（弥太郎）
なおケタ合わせ（町名の文字数が合わなければそろいまへん）が空白でええのなら
x(i,n)=mid(mch,u,1)に変更してくらはい。
'------------------------
Sub mayo()
Dim i As Long, j As Long, n As Integer, u As Integer, t
Dim Cnt As Integer, m As Integer, data, tbl, x, mch
tbl = Range("a1", Range("a" & Rows.Count).End(xlUp))
ReDim x(1 To UBound(tbl, 1), 1 To Columns.Count)
With CreateObject("vbscript.regexp")
.Pattern = "(.+町)(\d+番地|\d+丁目)(\d+$|\d+番)(\d+号)*(-(\d+)号(.+)*)*"
For i = 1 To UBound(tbl, 1)
tbl(i, 1) = Replace(StrConv(tbl(i, 1), vbNarrow), " ", "")
n = 0
If .test(tbl(i, 1)) Then
For m = 1 To 5
data = .Replace(tbl(i, 1), "$" & m)
If data = "" Then Exit For
t = Val(data)
If Not data Like "*町" Then
mch = Format(IIf(m = 5, .Replace(tbl(i, 1), "$6"), t), _
IIf(m = 5, "@@@@@", "@@@@"))
mch = IIf(m = 5, "-", "") & mch & Right(data, Len(data) - Len(t))
Else
mch = data
End If
For u = 1 To Len(mch)
n = n + 1
x(i, n) = IIf(Mid(mch, u, 1) = " ", "x", Mid(mch, u, 1))
Next u
Next m
Cnt = IIf(Cnt < n, n, Cnt)
End If
Next i
End With
'Range("b1").Resize(, Cnt).EntireColumn.Insert
Range("b1").Resize(UBound(tbl, 1), Cnt) = x
'Range("b1").Resize(, Cnt).Columns.AutoFit
End Sub
不要な変数を削除 totl 5/24 8:00
ありがとうございます。返事が遅くなりまして申し訳ありません。
私の説明が足りなかったのですが、例では「□□町」のように書きましたが、実際の住所は「〜町」だけではなく「杉塚」「大坪」のように「町」が最後に付かない町名もあります。また、□□町10丁目10番10号−10号と部屋番が付く場合ですが、部屋番の−直前の「号」は無く、□□町10丁目10番10−10号でした。説明不足に確認不足のまま書いてしまい大変反省しております。
それで「〜町」と「町」が最後に付かない住所については、住所の町名末尾に「町」を置換で追加して(杉塚町のように)から、ご提示頂いたコードを早速試させていただきましたところ、きちんと文字分割まで処理出来ました。ありがとうございました。
また、部屋番号があるものについては、edstr = Array("丁目", "番地", "番", "号−", "号")の部分を edstr = Array("丁目", "番地", "番", "−", "号")と変更して処理をかけるとうまくいきました。
このような変更・使い方で大丈夫でしょうか？ichinose様のコードを見ても、どこでどのような処理が行われているのかわからない部分が多いので心配ですが･･･。
ありがとうございます。返事が遅くなりまして申し訳ありません。
上のichinose様宛てのお返事でも書いたのですが･･･住所の町名が「〜町」以外があること、部屋番号の−直前の「号」が不要でした。私の説明を前提でわざわざ組んで頂いているのに本当に申し訳ないです。また、町名の文字数ですが、ひとつのシートに同一町名の住所しか入っていないので、シート毎には違いますが、取り敢えずシート内では町名の文字数は全て同じになります。
それで、町名に関してはichinose様のVBAの場合と同じように置換を使って全ての町名を「〜町」と置き換えを行ってから処理をかけてみました(列挿入、オートフィットはアリ、桁合わせは空白の方が良かったので、x(i, n) = IIf(Mid(mch, u, 1) = " ", "x", Mid(mch, u, 1))の部分を x(i,n)=mid(mch,u,1)に変更しました)。
結果としては、部屋番号がないものに関しては完璧でした。部屋番号があるものについては、
例：
二日市北1丁目6番1−201号 のような住所が、
___0日市北町1-201号1丁目1-201号___6番1-201号___1-201号-1-201号-201号__________
のようになってしまいます(_は半角スペースです)。部屋番号がある住所は全てこのパターンになっています。
弥太郎様のコードでは正規表現？での処理になっているのでしょうか？？それこそ私には全くわからないので、どこをどういじって良いものかわかりませんでした。
大変厚かましいのですが･･･もし宜しければ、どこをどのように修正すれば良いかご教授願えませんでしょうか？
>このような変更・使い方で大丈夫でしょうか？ うまくいっているなら、よいですが、「町」がなくても対応するようにしました。
Function edit_add(ByVal add As Variant) As String
Dim g0 As Long
Dim g1 As Long
Dim g2 As Long
Dim f_fnd As Long
Dim edstr As Variant
Dim eddem As Variant
Dim wk As Variant
edstr = Array("丁目", "番地", "番", "−", "号")
eddem = Array(2, 4, 4, 4, 4)
edit_add = ""
add = RTrim(add)
f_fnd = 0
For g1 = LBound(edstr) To UBound(edstr)
If Len(add) > 0 Then
g0 = InStrRev(add, edstr(g1))
If g0 > 0 Then
If f_fnd = 0 Then
wk = Left(add, g0 - 1)
For g2 = Len(wk) To 1 Step -1
If StrConv(Mid(wk, g2, 1), vbNarrow) Like "[!0-9]" Then
edit_add = Left(add, g2)
add = Mid(add, g2 + 1)
g0 = InStrRev(add, edstr(g1))
Exit For
End If
Next
f_fnd = 1
End If
edit_add = edit_add & _
Format(Left(add, g0 - 1), _
String(eddem(g1), "@") & """" & edstr(g1) & """")
add = Mid(add, g0 + Len(edstr(g1)))
End If
Else
Exit For
End If
Next
If Len(add) > 0 Then
edit_add = edit_add & Format(add, "@@@@")
End If
End Function
edit_addというFunctionプロシジャーだけ差し替えてください。
ichinose@球技大会で身体中が痛い
どんなパターンが有るんか分かりまへんが、こんな塩梅でよろしいんでっしゃろか？
（弥太郎）
'---------------------------
Sub mayo2()
Dim i As Long, j As Long, n As Integer, u As Integer, t
Dim Cnt As Integer, data, tbl, x, mch
tbl = Range("a1", Range("a" & Rows.Count).End(xlUp))
ReDim x(1 To UBound(tbl, 1), 1 To Columns.Count)
With CreateObject("vbscript.regexp")
.Pattern = "(^D+)?((\d+)(\D+)?)"
.Global = True
For i = 1 To UBound(tbl, 1)
tbl(i, 1) = Replace(StrConv(tbl(i, 1), vbNarrow), " ", "")
n = 0
If .test(tbl(i, 1)) Then
mch = .Replace(tbl(i, 1), "$1")
For Each data In .Execute(tbl(i, 1))
t = Val(data)
mch = mch & Format(t, "@@@@") & Right(data, Len(data) - Len(t))
Next
For u = 1 To Len(mch)
n = n + 1
x(i, n) = Mid(mch, u, 1)
Next u
Cnt = IIf(Cnt < n, n, Cnt)
End If
Next i
End With
Range("b1").Resize(UBound(tbl, 1), Cnt) = x
End Sub
インデントしゅせぇ。
（弥太郎）9:25
修正までして頂き誠にありがとうございます。お二方のコードのどらも無事に出来ました。大変助かりました。マクロというのは同じ結果を求めるのにいろいろな処理方法があるのですね。とても参考になりました。ありがとうございました。
（mayo）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.