VBA 簡易版 住所分解コード化ツールは、
Excel VBA用です。
暇です。
ACCESS VBA ではどうなるか 暇にまかせて↓やってみました。
当初、ORACLE版に比べてかなり遅かったんですが、
INDEXを調整したり、不要な検索をまとめたりしたら、
逆にこっちの方が、ORACLE + EXCEL VBAの倍以上の速さになりました。
2,000件で、5秒程です。(初回は10秒)
あと、住所マスタを検索しないモード(mstFlgで切り替え)でも、実行できるようにしました。
********************************************************************************
Option Compare Database
Option Explicit
' グローバル変数
Type WORK
kenCd As String
sikuCd As String
oazaCd As String
koazaCd As String
postNo As String
kenMei As String
sikuMei As String
oazaMei As String
koazaMei As String
bantiMei As String
kataMei As String
End Type
Dim wk As WORK
Dim sv As WORK
Dim inAdrs As String ' 変換元住所
Dim stAdrs As String ' 住所ワーク
Dim DB As DAO.Database
Dim wrkCurrent As DAO.Workspace
Const mstFlg As Boolean = True ' マスタ検索する(True)／しない(False)
Function JusyoBunkai()
If vbOK = MsgBox("住所分解を実施しますか？", vbOKCancel, "処理確認") Then
Call 住所分解実行
Else
MsgBox "キャンセルしました"
End If
End Function
' 分解メイン =====================================
Sub 住所分解実行()
Set wrkCurrent = DBEngine.Workspaces(0)
Dim startTime As Single: startTime = Timer
Dim endTime As Single
Dim runTime As Single
' 既存レコードの全削除
Set DB = CurrentDb
DB.Execute ("DELETE FROM 住所分解テーブル")
' 変換元住所
Dim rs1 As Recordset
Set rs1 = CurrentDb.OpenRecordset("住所テーブル")
' 住所分解後結果
Dim rs2 As Recordset
Set rs2 = CurrentDb.OpenRecordset("住所分解テーブル")
wrkCurrent.BeginTrans
Dim i As Long: i = 0
Do Until rs1.EOF
i = i + 1
sv = wk
Call initWork(wk)
inAdrs = rs1!住所
inAdrs = StrConv(inAdrs, vbWide)
Call setKenMei ' 都道府県分解
Call setSikuMei ' 市区町村分解
Call setAzaMei ' 町・字分解
Call setBankata ' 番地・方書分解
rs2.AddNew
rs2!テーブルキー = rs1!住所録ID
Call fieldSet(rs2)
rs2.Update
If Int(i / 100) * 100 = i Then
wrkCurrent.CommitTrans
wrkCurrent.BeginTrans
' endTime = Timer: runTime = Int(endTime - startTime)
' MsgBox "更新カウント：" & i & vbNewLine & "経過時間（" & runTime & "秒）"
End If
rs1.MoveNext
Loop
wrkCurrent.CommitTrans
rs2.Close
Set rs2 = Nothing
rs1.Close
Set rs1 = Nothing
endTime = Timer: runTime = Int(endTime - startTime)
MsgBox "住所分解処理終了！ " & Format(i, "#,#") & "件" & vbNewLine & "経過時間（" & runTime & "秒）"
End Sub
' 変数初期化 =====================================
Public Sub initWork(ByRef Data As WORK)
Dim nul As WORK
Data = nul
End Sub
' 明細処理 =======================================
Private Sub fieldSet(rs2)
rs2!住所 = inAdrs ' 分解元住所
rs2!POST = wk.postNo ' 郵便番号
If wk.kenCd <> "" Then
rs2!県CD = wk.kenCd ' 都道府県コード
End If
If wk.sikuCd <> "" Then
rs2!市町CD = wk.sikuCd ' 市区町村コード
End If
rs2!大字CD = wk.oazaCd ' 町・大字コード
rs2!小字CD = wk.koazaCd ' 小字・丁目コード
rs2!都道府県名 = wk.kenMei ' 都道府県名
rs2!市区町村名 = wk.sikuMei ' 市区町村名
rs2!大字名 = wk.oazaMei ' 町・大字名
rs2!小字名 = wk.koazaMei ' 小字・丁目名
rs2!番地 = wk.bantiMei ' 番地
rs2!方書 = wk.kataMei ' 方書
End Sub
' 都道府県名分解 =================================
Private Sub setKenMei()
Dim mySql As String: mySql = "SELECT NEWKENCD FROM MST_ADRS1 WHERE KENMEI = '"
Dim fd As Variant
If (Mid(inAdrs, 3, 1) = "県" Or _
Mid(inAdrs, 3, 1) = "府" Or _
Left(inAdrs, 3) = "北海道" Or _
Left(inAdrs, 3) = "東京都") Then
wk.kenMei = Left(inAdrs, 3)
ElseIf (Mid(inAdrs, 4, 1) = "県") Then
wk.kenMei = Left(inAdrs, 4)
Else
stAdrs = inAdrs
Exit Sub
End If
If wk.kenMei = sv.kenMei Then
wk.kenCd = sv.kenCd
Else
mySql = mySql & wk.kenMei & "'"
fd = func_selSql(mySql)
If fd(0) <> "NOT FOUND" Then
wk.kenCd = fd(0)
End If
End If
stAdrs = Mid(inAdrs, Len(wk.kenMei) + 1)
End Sub
' 市区町村名分解 =================================
Private Sub setSikuMei()
Dim mySql As String: mySql = "SELECT NEWSIKUCD FROM MST_ADRS2 WHERE "
Dim r As Integer: r = 0
Dim fd As Variant
If (stAdrs = "") Then: Exit Sub
r = 99
If InStr(stAdrs, "市") > 0 Then
If InStr(stAdrs, "区") > 0 Then
Select Case Left(stAdrs, 3)
' 区のある政令指定都市でない市
Case "伊達市", "石狩市", "八戸市", "盛岡市", "奥州市", "上越市", "宇陀市", "姫路市"
wk.sikuMei = Left(stAdrs, 3)
Case "南相馬市"
wk.sikuMei = Left(stAdrs, 4)
Case Else
wk.sikuMei = Left(stAdrs, InStr(stAdrs, "区"))
End Select
Else
wk.sikuMei = Left(stAdrs, InStr(stAdrs, "市"))
End If
r = Len(wk.sikuMei)
End If
If (InStr(stAdrs, "区") > 0) And (InStr(stAdrs, "区") < r) Then ' 東京都
wk.sikuMei = Left(stAdrs, InStr(stAdrs, "区"))
r = Len(wk.sikuMei)
End If
If (InStr(stAdrs, "町") > 0) And (InStr(stAdrs, "町") < r) Then
wk.sikuMei = Left(stAdrs, InStr(stAdrs, "町"))
r = Len(wk.sikuMei)
wk.sikuMei = Mid(wk.sikuMei, InStr(stAdrs, "郡") + 1)
End If
If (InStr(stAdrs, "村") > 0) And (InStr(stAdrs, "村") < r) Then
wk.sikuMei = Left(stAdrs, InStr(stAdrs, "村"))
r = Len(wk.sikuMei)
wk.sikuMei = Mid(wk.sikuMei, InStr(stAdrs, "郡") + 1)
End If
If (r = 99) Then: Exit Sub
If (wk.sikuMei = sv.sikuMei) Then
wk.sikuCd = sv.sikuCd
wk.kenCd = sv.kenCd
Else
If wk.kenCd <> "" Then
mySql = mySql & " NEWKENCD = " & wk.kenCd & " AND SIKUMEI = '" & wk.sikuMei & "'"
Else
mySql = mySql & " SIKUMEI = '" & wk.sikuMei & "'"
End If
fd = func_selSql(mySql)
If fd(0) = "NOT FOUND" Then ' <== 見付からないので例外を当てる
wk.sikuCd = ""
r = func_sikuElse(r)
Else
wk.sikuCd = fd(0)
End If
End If
If (wk.kenCd = "" And wk.sikuMei <> "") Then
mySql = "SELECT NEWKENCD FROM MST_ADRS2 WHERE SIKUMEI = '" & wk.sikuMei & "'"
fd = func_selSql(mySql)
If fd(0) <> "NOT FOUND" Then
wk.kenCd = fd(0)
End If
End If
stAdrs = Mid(stAdrs, r + 1)
End Sub
' 例外地名 =======================================
Private Function func_sikuElse(r) As Integer
Dim mySql As String: mySql = "SELECT NEWSIKUCD FROM MST_ADRS2 WHERE "
Dim fd As Variant
Dim rr As Integer ' 例外市区町村文字数
func_sikuElse = r ' 見付からなければ、元の文字数を返す
' 例外市区町村名
rr = 3
Select Case Left(stAdrs, 3)
Case "市川市", "市原市", "羽村市", "大町市", "大村市": wk.sikuMei = Left(stAdrs, 3)
Case "田村市", "都城市", "村山市", "村上市", "町田市": wk.sikuMei = Left(stAdrs, 3)
Case "水沢市", "江刺市": wk.sikuMei = "奥州市"
Case Else: rr = 0
End Select
If rr = 0 Then
rr = 4
Select Case Left(stAdrs, 4)
Case "四日市市", "廿日市市", "野々市市", "十日町市", "東村山市", "南相馬市": wk.sikuMei = Left(stAdrs, 4)
Case "鳩ヶ谷市": wk.sikuMei = "川口市"
Case Else: rr = 0
End Select
End If
If rr = 0 Then
Select Case Left(stAdrs, 5)
Case "武蔵村山市": wk.sikuMei = "武蔵村山市": rr = 5
End Select
End If
If rr = 0 Then
rr = 6
Select Case Left(stAdrs, 6)
Case "余市郡仁木町", "余市郡余市町", "芳賀郡市貝町", "神崎郡市川町": wk.sikuMei = Mid(stAdrs, 4, 3)
Case "高市郡高取町", "杵島郡大町町", "吉野郡下市町", "柴田郡村田町": wk.sikuMei = Mid(stAdrs, 4, 3)
Case "田村郡三春町", "田村郡小野町", "佐波郡玉村町", "宗谷郡猿払村": wk.sikuMei = Mid(stAdrs, 4, 3)
Case "三宅島三宅村": wk.sikuMei = Mid(stAdrs, 4, 3)
Case "幡豆郡一色町", "幡豆郡吉良町", "幡豆郡幡豆町": wk.sikuMei = "西尾市"
Case "岩手郡滝沢村": wk.sikuMei = "滝沢市"
Case "簸川郡斐川町": wk.sikuMei = "出雲市"
Case Else: rr = 0
End Select
End If
If rr = 0 Then
rr = 7
Select Case Left(stAdrs, 7)
Case "中新川郡上市町", "東村山郡山辺町", "東村山郡中山町": wk.sikuMei = Mid(stAdrs, 5, 3)
Case "西村山郡河北町", "西村山郡西川町", "西村山郡朝日町", "西村山郡大江町": wk.sikuMei = Mid(stAdrs, 5, 3)
Case "下都賀郡岩舟町", "上都賀郡西方町": wk.sikuMei = "栃木市"
Case "南埼玉郡白岡町": wk.sikuMei = "白岡市"
Case "東磐井郡藤沢町": wk.sikuMei = "一関市"
Case "八束郡東出雲町": wk.sikuMei = "松江市"
Case "石川郡野々市町": wk.sikuMei = "野々市市"
Case "愛知郡長久手町": wk.sikuMei = "長久手市"
Case "胆沢郡金ケ崎町": wk.sikuMei = "金ケ崎町"
Case "刈田郡七ケ宿町": wk.sikuMei = "七ヶ宿町"
Case "余市郡赤井川村": wk.sikuMei = "赤井川村"
Case "高市郡明日香村": wk.sikuMei = "明日香村"
Case "名古屋市中村区": wk.sikuMei = "名古屋市中村区"
Case Else: rr = 0
End Select
End If
If rr = 0 Then
rr = 8
Select Case Left(stAdrs, 8)
Case "北村山郡大石田町": wk.sikuMei = "大石田町"
Case "山武郡大網白里町": wk.sikuMei = "大網白里市"
Case Else: rr = 0
End Select
End If
If rr = 0 Then
Select Case Left(stAdrs, 9)
Case "西八代郡市川三郷町": wk.sikuMei = "市川三郷町": rr = 9
End Select
End If
' 他に、市・区・町・村の出現順・位置により誤分解あれば考慮・追加要
If rr > 0 Then
If wk.kenCd <> "" Then
mySql = mySql & " NEWKENCD = " & wk.kenCd & " AND SIKUMEI = '" & wk.sikuMei & "'"
Else
mySql = mySql & " SIKUMEI = '" & wk.sikuMei & "'"
End If
fd = func_selSql(mySql)
If fd(0) <> "NOT FOUND" Then
wk.sikuCd = fd(0)
func_sikuElse = rr
End If
End If
End Function
' 町字分解 =======================================
Private Sub setAzaMei()
Dim azaMei As String: azaMei = ""
Dim azaMei2 As String: azaMei2 = ""
Dim stAdrs2 As String: stAdrs2 = ""
Dim r As Integer
Dim mySql As String
Dim fd As Variant
r = InStr(stAdrs, "丁目") ' 丁目で分割
If r > 0 Then
If Mid(stAdrs, r + 2, 1) = "東" Or _
Mid(stAdrs, r + 2, 1) = "西" Or _
Mid(stAdrs, r + 2, 1) = "南" Or _
Mid(stAdrs, r + 2, 1) = "北" Then
r = r + 1
End If
azaMei = Left(stAdrs, r + 1)
azaMei = func_kanSuji(azaMei)
stAdrs = Mid(stAdrs, r + 2)
Else
r = func_sujiIchI(stAdrs) ' 数字番地で分割
If r > 0 Then
azaMei = Left(stAdrs, r - 1)
stAdrs = Mid(stAdrs, r)
End If
End If
If (azaMei = "") Then
Exit Sub
End If
If (wk.kenCd = "" Or wk.sikuCd = "") Then
wk.oazaMei = azaMei
Exit Sub
End If
azaMei2 = Replace(azaMei, "大字", "")
azaMei2 = Replace(azaMei2, "小字", "")
If Left(azaMei2, 1) = "字" And Len(azaMei2) > 1 Then
azaMei2 = Mid(azaMei2, 2)
End If
mySql = " FROM MST_ADRS3 WHERE NEWKENCD = " & wk.kenCd & _
" AND NEWSIKUCD = " & wk.sikuCd & _
" AND ((OAZAMEI + KOAZAMEI LIKE '*" & azaMei2 & _
"') OR (OAZAMEI LIKE '*" & azaMei2 & "' AND KOAZAMEI IS NULL))"
fd = func_selSql("SELECT OAZAMEI,NEWOAZACD,KOAZAMEI,NEWKOAZACD,YUBIN" & mySql)
If fd(0) <> "NOT FOUND" Then
wk.oazaMei = fd(0)
End If
If (wk.oazaMei = "") Then ' 番地先頭を丁目にしてリトライ
r = InStr(stAdrs, "－")
If (r > 0 And InStr(azaMei, "丁目") < 1) Then
azaMei2 = azaMei & Left(stAdrs, r - 1) & "丁目"
azaMei2 = func_kanSuji(azaMei2)
stAdrs2 = Mid(stAdrs, r + 1)
mySql = " FROM MST_ADRS3 WHERE NEWKENCD = " & wk.kenCd & " AND NEWSIKUCD = " & wk.sikuCd _
& " AND OAZAMEI + KOAZAMEI = '" & azaMei2 & "'"
fd = func_selSql("SELECT OAZAMEI,NEWOAZACD,KOAZAMEI,NEWKOAZACD,YUBIN" & mySql)
If (fd(0) <> "NOT FOUND") Then
wk.oazaMei = fd(0)
stAdrs = stAdrs2
End If
End If
End If
If (wk.oazaMei = "") Then ' 見付からなかった
wk.oazaMei = azaMei
Else
wk.oazaCd = fd(1)
wk.koazaMei = fd(2)
wk.koazaCd = fd(3)
wk.postNo = fd(4)
End If
End Sub
' 番地・方書分割 =================================
Private Sub setBankata()
Dim r As Integer
r = InStr(stAdrs, " ")
If (r > 0) Then
wk.bantiMei = Left(stAdrs, r - 1)
wk.kataMei = Mid(stAdrs, r + 1)
Else
wk.bantiMei = stAdrs
End If
End Sub
' マスタ検索 =====================================
Private Function func_selSql(mySql) As Variant
Dim rs As DAO.Recordset
Dim fd(5) As String
Dim i As Integer
If mstFlg = False Then ' 住所マスタ検索しない場合
fd(0) = "NOT FOUND"
func_selSql = fd
Exit Function
End If
Set rs = DB.OpenRecordset(mySql)
If rs.RecordCount = 0 Then
fd(0) = "NOT FOUND"
Else
For i = 0 To rs.Fields.Count - 1
If IsNull(rs.Fields(i).Value) Then
fd(i) = ""
Else
fd(i) = rs.Fields(i).Value
End If
Next i
End If
rs.Close
Set rs = Nothing
func_selSql = fd
End Function
' 丁目数字変換（アラビア数字⇒漢数字）============
Private Function func_kanSuji(azaMei) As String
func_kanSuji = azaMei
' If azaMei = StrConv(azaMei, vbNarrow) Then: Exit Function ' 英数字なし
Dim arbSu As Variant
Dim knjSu As Variant
Dim i As Long
arbSu = Split("１,２,３,４,５,６,７,８,９,一０,一一,一二,一三,一四,一五,一六,一七,一八,一九,二０,二一,二二,二三,二四", ",")
knjSu = Split("一,二,三,四,五,六,七,八,九,十,十一,十二,十三,十四,十五,十六,十七,十八,十九,二十,二十一,二十二,二十三,二十四", ",")
For i = 0 To UBound(arbSu)
azaMei = Replace(azaMei, arbSu(i), knjSu(i))
Next i
func_kanSuji = azaMei
End Function
' 数字位置の検出 =================================
Private Function func_sujiIchI(str As String) As Integer
Dim r As Integer: r = Len(str) + 1
Dim i As Integer
Dim tmp As String
For i = 1 To 9
tmp = StrConv(i, vbWide)
If (InStr(str, tmp) > 0 And InStr(str, tmp) < r) Then: r = InStr(str, tmp)
Next i
func_sujiIchI = r
End Function
Function FormJusyoBunkai()
Call 画面入力住所分解
End Function
' 画面分解メイン =================================
Sub 画面入力住所分解()
Dim fm As Form
Set fm = Forms("住所分解フォーム")
Set DB = CurrentDb
Call initWork(wk)
If IsNull(fm.入力住所.Value) Then
MsgBox "住所を入力して下さい！"
Exit Sub
End If
inAdrs = fm.入力住所.Value
inAdrs = StrConv(inAdrs, vbWide)
Call setKenMei ' 都道府県分解
Call setSikuMei ' 市区町村分解
Call setAzaMei ' 町・字分解
Call setBankata ' 番地・方書分解
fm.postNo.Caption = wk.postNo ' 郵便番号
If wk.kenCd <> "" Then
fm.kenCd.Caption = wk.kenCd ' 都道府県コード
End If
If wk.sikuCd <> "" Then
fm.sikuCd.Caption = wk.sikuCd ' 市区町村コード
End If
fm.oazaCd.Caption = wk.oazaCd ' 町・大字コード
fm.koazaCd.Caption = wk.koazaCd ' 小字・丁目コード
fm.kenMei.Caption = wk.kenMei ' 都道府県名
fm.sikuMei.Caption = wk.sikuMei ' 市区町村名
fm.oazaMei.Caption = wk.oazaMei ' 町・大字名
fm.koazaMei.Caption = wk.koazaMei ' 小字・丁目名
fm.bantiMei.Caption = wk.bantiMei ' 番地
fm.kataMei.Caption = wk.kataMei ' 方書
fm.Refresh
End Sub
