この前の投稿記事等の
住所分解コード化ツールで、住所コードマスタを使用しているのですが、
どうやって作ったかなんですが、
①．総務省トップ > 政策 > 地方行財政 > 電子自治体 > 全国地方公共団体コード
http://www.soumu.go.jp/denshijiti/code.html
と
②．国土交通省国土政策局 国土情報課 > 位置参照情報ダウンロードサービス
http://nlftp.mlit.go.jp/cgi-bin/isj/dls/_choose_method.cgi
と
③．住所.jpの住所データ
http://jusyo.jp/csv/new.php
からダウンロードしたファイルを元に作成しています。
※有償のデータなら訳ないのですが、無償データで作るという前提です。
ただ、どれかひとつで目的とするマスタが作れない。ので、どうしても齟齬が出ます。
①は、政令指定都市情報がある。
②は、字コードがあるが、郵便番号がない。
③は、郵便番号はあるが、字コードが独自採番(←こんなん使えない)ので郵便番号更新用とする。
そして、②と③は、字名に微妙に違いがあったりする。
※①②③以外で、もっと便利な無償公開データをご存知なら、コメント頂けるとありがたいです。
参考にソースを載せます。
といっても、自分では、シート上で加工してゴリゴリ登録したので、
今回のソースは、未実行の多分バグあり版です。(無責任)
目的のテーブルレイアウトは、ソースから推測してください。
ＤＢの接続は、他のORACLE用ソースと同様ですので割愛しています。
あくまでも、自分の学習用(VBAでやったらどうなるか)とあくまで参考用です。
若し、実行させて、ここ違うよというのがありましたら。
是非、コメントください。ものすごくありがたいです。m( _ _ )m
郵便番号は他の郵便番号一覧を元に、住所を文字であてて
追加しています。
文字の表記の違いにより、３分の１ぐらい(県によって全然のところもある)で、
改善の余地ありなのですが・・・、処理速度が膨大、改善の余地ありです。
よい手がありましたら、教えてもらえると大感激です。
======================================================================
Option Explicit
' ツール>参照設定>Microsoft ActiveX Data Objects X.X Library
Dim OraCn As ADODB.Connection
Dim OraRs As ADODB.Recordset
Dim stSQL As String
Type Adrs3
AzaCd As String
KenCd As String
SikuCd As String
Oazacd As String
KoazaCd As String
OazaMei As String
KoazaMei As String
HaisiFlg As String
End Type
Sub 市区町村テーブル登録()
' 総務省トップ > 政策 > 地方行財政 > 電子自治体 > 全国地方公共団体コード
' http://www.soumu.go.jp/denshijiti/code.html
' からダウンロードしたEXCELファイルより登録する
Const InFILE As String = "000285753.xls"
Const InSheet1 As String = "H26.4.5現在の団体"
Const InSheet2 As String = "H26.4.5政令指定都市"
Dim i As Integer
Dim buf As String
Dim stSQL As String
Const stINS1 As String = "INSERT INTO MST_ADRS1(KENCD,KKENMEI,KENMEI,KEYKENCD,HAISIFLG) VALUES("
Const stINS2 As String = "INSERT INTO MST_ADRS2(SIKUCD,KSIKUMEI,SIKUMEI,KEYKENCD,KEYSIKUCD,KENMEIFLG,HAISIFLG) VALUES("
Const stUPD2 As String = "UPDATE MST_ADRS2 SET KENMEIFLG = 1 WHERE SIKUCD = "
On Err GoTo Err_Han
Call DB_CONNECT
OraCn.BeginTrans
Workbooks.Open ThisWorkbook.Path & "\" & InFILE
' 団体の登録
Sheets(InSheet1).Select
i = 2
Do While Cells(i, 1).Value <> ""
Cells(i, 1).Select
buf = Cells(i, 1).Value
If Mid(buf, 3, 3) = "000" Then
stSQL = stINS1 & Left(buf, 2) & ",'" & Cells(i, 4).Value & "','" & _
Cells(i, 2).Value & "'," & Left(buf, 2) & ",0)"
Else
stSQL = stINS2 & Left(buf, 5) & ",'" & Cells(i, 5).Value & "','" & _
Cells(i, 2).Value & "'," & Left(buf, 2) & "," & Mid(buf, 3, 3) & ",0,0)"
End If
Set OraRs = OraCn.Execute(stSQL)
i = i + 1
If i = Int(i / 100) * 100 Then
OraCn.CommitTrans
OraCn.BeginTrans
DoEvents
End If
Loop
Set OraRs = Nothing
' 政令指定都市の登録
Sheets(InSheet2).Select
i = 2
Do While Cells(i, 1).Value <> ""
Cells(i, 1).Select
buf = Cells(i, 1).Value
If Right(Cells(i, 2).Value, 1) = "区" Then
stSQL = stINS2 & Left(buf, 5) & ",'" & StrConv(StrConv(Cells(i, 3).Value, vbKatakana), vbNarrow) & "','" & _
Cells(i, 2).Value & "'," & Left(buf, 2) & "," & Mid(buf, 3, 3) & ",1,0)"
Else
stSQL = stUPD2 & Left(buf, 5)
End If
Set OraRs = OraCn.Execute(stSQL)
i = i + 1
Loop
OraCn.CommitTrans
MsgBox "都道府県テーブル登録終了！"
ActiveWorkbook.Close SaveChanges:=False
Obj_Rls:
Set OraRs = Nothing
OraCn.Close
Set OraCn = Nothing
Exit Sub
Err_Han:
MsgBox (Err.Description)
GoTo Obj_Rls
End Sub
Private Sub 大字小字データ登録()
' 国土交通省国土政策局 国土情報課 > 位置参照情報ダウンロードサービス
' http://nlftp.mlit.go.jp/cgi-bin/isj/dls/_view_cities_wards.cgi
' からダウンロードしたCSVファイルより登録する
Const NenDo As String = "_2012" '<-- ダウンロードファイルに合わせて変更する
Dim i As Integer
Dim j As Long
Dim Mst As Adrs3
Dim MySheet As Worksheet
Dim stCd As String
Dim stKenCd As String
Dim stSQL As String
Const stINS3 As String = "INSERT INTO MST_ADRS3(AZACD,KEYKENCD,KEYSIKUCD,KEYOAZACD,KEYKOAZACD,OAZAMEI,KOAZAMEI,HAISIFLG)"
On Err GoTo Err_Han
Call DB_CONNECT
OraCn.BeginTrans
For i = 1 To 47
stKenCd = Format(CStr(i), "00")
If Dir(ThisWorkbook.Path & "\" & stKenCd & NenDo & ".csv", vbNormal) = "" Then
MsgBox (stKenCd & NenDo & ".csvは存在しません！")
GoTo Next_Ken
End If
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & stKenCd & NenDo & ".csv"
Set MySheet = ActiveWorkbook.Worksheets(stKenCd & NenDo)
MySheet.Columns("A:J").Sort key1:=MySheet.Columns(5), order1:=xlAscending, Header:=xlYes
j = 2
Do While Cells(j, 1) <> ""
stCd = Format(Cells(j, 5).Value, "000000000000")
Mst.AzaCd = stCd
Mst.KenCd = Left(stCd, 2)
Mst.SikuCd = Mid(stCd, 3, 3)
Mst.Oazacd = Mid(stCd, 6, 4)
Mst.KoazaCd = Right(stCd, 3)
Mst.HaisiFlg = "0"
If Mst.KoazaCd = "000" Then
Mst.OazaMei = Cells(j, 6).Value
Mst.KoazaMei = ""
Else
If Left(stCd, 9) = Left(Cells(j - 1, 5).Value, 9) Then '一行上と同じ大字か？
Mst.OazaMei = GetOazaMei(j)
Mst.KoazaMei = GetKoazaMei(j)
Else '大字中の最初の小字
Mst.OazaMei = GetOazaMei(j + 1)
Mst.KoazaMei = GetKoazaMei(j + 1)
End If
End If
stSQL = stINS3 & " VALUES('" & Mst.AzaCd & "'," & _
Mst.KenCd & "," & _
Mst.SikuCd & ",'" & _
Mst.Oazacd & "','" & _
Mst.KoazaCd & "','" & _
Mst.OazaMei & "','" & _
Mst.KoazaMei & "','" & _
Mst.HaisiFlg & "')"
Set OraRs = OraCn.Execute(stSQL)
' 次の行へ
j = j + 1
If j = Int(j / 100) * 100 Then
Application.ScreenUpdating = True
Cells(j, 1).Select
Application.ScreenUpdating = False
OraCn.CommitTrans
OraCn.BeginTrans
DoEvents
End If
Loop
Next_Ken:
Next i
Application.ScreenUpdating = True
OraCn.CommitTrans
MsgBox "大字小字テーブル登録終了！"
ActiveWorkbook.Close SaveChanges:=False
Obj_Rls:
Set OraRs = Nothing
OraCn.Close
Set OraCn = Nothing
Exit Sub
Err_Han:
MsgBox (Err.Description)
GoTo Obj_Rls
End Sub
' 大字名取得
Function GetOazaMei(pRow As Long) As String
Dim i As Integer
Dim stAzaMei1 As String: stAzaMei1 = Cells(pRow - 1, 6).Value
Dim stAzaMei2 As String: stAzaMei2 = Cells(pRow, 6).Value
For i = 1 To Len(stAzaMei1)
If Left(stAzaMei1, i) <> Left(stAzaMei2, i) Then
If i = 1 Then
GetOazaMei = ""
Else
GetOazaMei = Left(stAzaMei2, i - 1)
End If
Exit Function
End If
Next i
GetOazaMei = stAzaMei2
End Function
' 小字名取得
Function GetKoazaMei(pRow As Long) As String
Dim i As Integer
Dim stAzaMei1 As String: stAzaMei1 = Cells(pRow - 1, 6).Value
Dim stAzaMei2 As String: stAzaMei2 = Cells(pRow, 6).Value
For i = 1 To Len(stAzaMei1)
If Left(stAzaMei1, i) <> Left(stAzaMei2, i) Then
If i = 1 Then
GetKoazaMei = stAzaMei2
Else
GetKoazaMei = Mid(stAzaMei2, i)
End If
Exit Function
End If
Next i
GetKoazaMei = ""
End Function
Sub 郵便番号更新()
' 住所.jpの住所データCSVを元に郵便番号を更新する
' http://jusyo.jp/csv/new.php
Dim i As Long: i = 2
Dim UpCnt As Long: UpCnt = 0
Dim stOazaMei As String
Dim stKoazaMei As String
Dim iKenCd As Integer
Dim iSikuCd As Integer
Dim vRowId As Variant
Dim stYubin As String
Const stSEL3 As String = "SELECT YUBIN,ROWID FROM MST_ADRS3 WHERE KEYKENCD = "
Const stUPD3 As String = "UPDATE MST_ADRS3 SET YUBIN = '"
Const cCnt As Integer = 10 'コミット間隔
On Err GoTo Err_Han
Call DB_CONNECT
OraCn.BeginTrans
If Dir(ThisWorkbook.Path & "\zenkoku.csv", vbNormal) = "" Then
MsgBox ("zenkoku.csvが存在しません！")
Exit Sub
End If
Workbooks.Open Filename:=ThisWorkbook.Path & "\zenkoku.csv"
Do While Cells(i, 1).Value <> ""
If Cells(i, 5).Value = 1 Or _
Cells(i, 17).Value <> "" Then GoTo Next_Line '一部地域、企業郵便番号は除く
iKenCd = CInt(Cells(i, 2).Value)
iSikuCd = CInt(Right(Cells(i, 3).Value, 3))
stOazaMei = 漢数字化(Trim(Cells(i, 12).Value))
stKoazaMei = 漢数字化(Trim(Cells(i, 16).Value))
stYubin = Cells(i, 5).Value
stSQL = stSEL3 & iKenCd & " AND KEYSIKUCD = " & iSikuCd
If stKoazaMei = "" Then
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI IS NULL"
Else
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI = '" & stKoazaMei & "'"
End If
Set OraRs = OraCn.Execute(stSQL)
If OraRs.EOF And InStr(stOazaMei, "ヶ") > 0 Then
stOazaMei = Replace(stOazaMei, "ヶ", "ケ")
stSQL = stSEL3 & iKenCd & " AND KEYSIKUCD = " & iSikuCd
If stKoazaMei = "" Then
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI IS NULL"
Else
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI = '" & stKoazaMei & "'"
End If
Set OraRs = OraCn.Execute(stSQL)
End If
If OraRs.EOF And InStr(stOazaMei, "ケ") > 0 Then
stOazaMei = Replace(stOazaMei, "ケ", "ヶ")
stSQL = stSEL3 & iKenCd & " AND KEYSIKUCD = " & iSikuCd
If stKoazaMei = "" Then
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI IS NULL"
Else
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI = '" & stKoazaMei & "'"
End If
Set OraRs = OraCn.Execute(stSQL)
End If
If OraRs.EOF And InStr(stOazaMei, "") > 0 Then
stOazaMei = Replace(stOazaMei, "", "塚")
stSQL = stSEL3 & iKenCd & " AND KEYSIKUCD = " & iSikuCd
If stKoazaMei = "" Then
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI IS NULL"
Else
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI = '" & stKoazaMei & "'"
End If
Set OraRs = OraCn.Execute(stSQL)
End If
If OraRs.EOF And InStr(stOazaMei, "塚") > 0 Then
stOazaMei = Replace(stOazaMei, "塚", "")
stSQL = stSEL3 & iKenCd & " AND KEYSIKUCD = " & iSikuCd
If stKoazaMei = "" Then
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI IS NULL"
Else
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI = '" & stKoazaMei & "'"
End If
Set OraRs = OraCn.Execute(stSQL)
End If
If OraRs.EOF And InStr(stOazaMei, "大字") < 1 Then
stOazaMei = "大字" & stOazaMei
stSQL = stSEL3 & iKenCd & " AND KEYSIKUCD = " & iSikuCd
If stKoazaMei = "" Then
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI IS NULL"
Else
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI = '" & stKoazaMei & "'"
End If
Set OraRs = OraCn.Execute(stSQL)
End If
If OraRs.EOF And InStr(stOazaMei, "字") < 1 Then
stOazaMei = "字" & stOazaMei
stSQL = stSEL3 & iKenCd & " AND KEYSIKUCD = " & iSikuCd
If stKoazaMei = "" Then
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI IS NULL"
Else
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI = '" & stKoazaMei & "'"
End If
Set OraRs = OraCn.Execute(stSQL)
End If
If OraRs.EOF = False Then
If OraRs.Fields(0) <> stYubin Then
vRowId = OraRs.Fields(1).Value
stSQL = stUPD3 & stYubin & "' WHERE ROWID = '" & vRowId & "'"
Set OraRs = OraCn.Execute(stSQL)
UpCnt = UpCnt + 1
Cells(i, 5).Interior.ColorIndex = 6
Cells(i, 12).Interior.ColorIndex = 6
Cells(i, 16).Interior.ColorIndex = 6
Application.ScreenUpdating = True
Cells(i, 1).Select
Application.ScreenUpdating = False
If UpCnt = Int(UpCnt / cCnt) * cCnt Then
OraCn.CommitTrans
OraCn.BeginTrans
End If
DoEvents
End If
Set OraRs = Nothing
Application.StatusBar = "更新( " & UpCnt & " / " & i - 1 & " 件)"
End If
Next_Line:
i = i + 1
Loop
Application.StatusBar = False
ActiveWorkbook.Close SaveChanges:=False
' Application.ScreenUpdating = True
MsgBox "郵便番号更新終了！ 更新件数:" & UpCnt
Obj_Rls:
OraCn.CommitTrans
OraRs.Close
Set OraRs = Nothing
OraCn.Close
Set OraCn = Nothing
Exit Sub
Err_Han:
MsgBox (Err.Description)
GoTo Obj_Rls
End Sub
' 漢数字化…但し、３桁の数字は未対応
Private Function 漢数字化(pAdrs As String) As String
Dim i As Integer '文字位置
Dim k As Integer '配列添字
Dim kSu As Variant: kSu = Array("〇", "一", "二", "三", "四", "五", "六", "七", "八", "九")
Dim aSu As Variant: aSu = Array("０", "１", "２", "３", "４", "５", "６", "７", "８", "９")
For k = 0 To 9
pAdrs = Replace(pAdrs, aSu(k), kSu(k))
Next k
' 丁目漢数字の10以上編集(十を挿入)
For i = 1 To Len(pAdrs) - 1
If isKNumber(Mid(pAdrs, i, 1)) And _
isKNumber(Mid(pAdrs, i + 1, 1)) Then
If Mid(pAdrs, i + 1, 1) = "〇" Then
pAdrs = Replace(pAdrs, "一〇", "十")
pAdrs = Replace(pAdrs, "〇", "十")
Else
If Mid(pAdrs, i, 1) = "一" Then
pAdrs = Left(pAdrs, i - 1) & "十" & Mid(pAdrs, i + 1)
Else
pAdrs = Left(pAdrs, i) & "十" & Mid(pAdrs, i + 1)
End If
End If
End If
Next i
漢数字化 = pAdrs
End Function
' 漢数字かどうか調べる
Function isKNumber(pMoji As String) As Boolean
Dim i As Integer
Dim kSu As Variant: kSu = Array("〇", "一", "二", "三", "四", "五", "六", "七", "八", "九")
isKNumber = False
For i = 0 To 9
If pMoji = kSu(i) Then
isKNumber = True
Exit For
End If
Next i
End Function
住所分解コード化ツールで、住所コードマスタを使用しているのですが、
どうやって作ったかなんですが、
①．総務省トップ > 政策 > 地方行財政 > 電子自治体 > 全国地方公共団体コード
http://www.soumu.go.jp/denshijiti/code.html
と
②．国土交通省国土政策局 国土情報課 > 位置参照情報ダウンロードサービス
http://nlftp.mlit.go.jp/cgi-bin/isj/dls/_choose_method.cgi
と
③．住所.jpの住所データ
http://jusyo.jp/csv/new.php
からダウンロードしたファイルを元に作成しています。
※有償のデータなら訳ないのですが、無償データで作るという前提です。
ただ、どれかひとつで目的とするマスタが作れない。ので、どうしても齟齬が出ます。
①は、政令指定都市情報がある。
②は、字コードがあるが、郵便番号がない。
③は、郵便番号はあるが、字コードが独自採番(←こんなん使えない)ので郵便番号更新用とする。
そして、②と③は、字名に微妙に違いがあったりする。
※①②③以外で、もっと便利な無償公開データをご存知なら、コメント頂けるとありがたいです。
参考にソースを載せます。
といっても、自分では、シート上で加工してゴリゴリ登録したので、
今回のソースは、未実行の多分バグあり版です。(無責任)
目的のテーブルレイアウトは、ソースから推測してください。
ＤＢの接続は、他のORACLE用ソースと同様ですので割愛しています。
あくまでも、自分の学習用(VBAでやったらどうなるか)とあくまで参考用です。
若し、実行させて、ここ違うよというのがありましたら。
是非、コメントください。ものすごくありがたいです。m( _ _ )m
郵便番号は他の郵便番号一覧を元に、住所を文字であてて
追加しています。
文字の表記の違いにより、３分の１ぐらい(県によって全然のところもある)で、
改善の余地ありなのですが・・・、処理速度が膨大、改善の余地ありです。
よい手がありましたら、教えてもらえると大感激です。
======================================================================
Option Explicit
' ツール>参照設定>Microsoft ActiveX Data Objects X.X Library
Dim OraCn As ADODB.Connection
Dim OraRs As ADODB.Recordset
Dim stSQL As String
Type Adrs3
AzaCd As String
KenCd As String
SikuCd As String
Oazacd As String
KoazaCd As String
OazaMei As String
KoazaMei As String
HaisiFlg As String
End Type
Sub 市区町村テーブル登録()
' 総務省トップ > 政策 > 地方行財政 > 電子自治体 > 全国地方公共団体コード
' http://www.soumu.go.jp/denshijiti/code.html
' からダウンロードしたEXCELファイルより登録する
Const InFILE As String = "000285753.xls"
Const InSheet1 As String = "H26.4.5現在の団体"
Const InSheet2 As String = "H26.4.5政令指定都市"
Dim i As Integer
Dim buf As String
Dim stSQL As String
Const stINS1 As String = "INSERT INTO MST_ADRS1(KENCD,KKENMEI,KENMEI,KEYKENCD,HAISIFLG) VALUES("
Const stINS2 As String = "INSERT INTO MST_ADRS2(SIKUCD,KSIKUMEI,SIKUMEI,KEYKENCD,KEYSIKUCD,KENMEIFLG,HAISIFLG) VALUES("
Const stUPD2 As String = "UPDATE MST_ADRS2 SET KENMEIFLG = 1 WHERE SIKUCD = "
On Err GoTo Err_Han
Call DB_CONNECT
OraCn.BeginTrans
Workbooks.Open ThisWorkbook.Path & "\" & InFILE
' 団体の登録
Sheets(InSheet1).Select
i = 2
Do While Cells(i, 1).Value <> ""
Cells(i, 1).Select
buf = Cells(i, 1).Value
If Mid(buf, 3, 3) = "000" Then
stSQL = stINS1 & Left(buf, 2) & ",'" & Cells(i, 4).Value & "','" & _
Cells(i, 2).Value & "'," & Left(buf, 2) & ",0)"
Else
stSQL = stINS2 & Left(buf, 5) & ",'" & Cells(i, 5).Value & "','" & _
Cells(i, 2).Value & "'," & Left(buf, 2) & "," & Mid(buf, 3, 3) & ",0,0)"
End If
Set OraRs = OraCn.Execute(stSQL)
i = i + 1
If i = Int(i / 100) * 100 Then
OraCn.CommitTrans
OraCn.BeginTrans
DoEvents
End If
Loop
Set OraRs = Nothing
' 政令指定都市の登録
Sheets(InSheet2).Select
i = 2
Do While Cells(i, 1).Value <> ""
Cells(i, 1).Select
buf = Cells(i, 1).Value
If Right(Cells(i, 2).Value, 1) = "区" Then
stSQL = stINS2 & Left(buf, 5) & ",'" & StrConv(StrConv(Cells(i, 3).Value, vbKatakana), vbNarrow) & "','" & _
Cells(i, 2).Value & "'," & Left(buf, 2) & "," & Mid(buf, 3, 3) & ",1,0)"
Else
stSQL = stUPD2 & Left(buf, 5)
End If
Set OraRs = OraCn.Execute(stSQL)
i = i + 1
Loop
OraCn.CommitTrans
MsgBox "都道府県テーブル登録終了！"
ActiveWorkbook.Close SaveChanges:=False
Obj_Rls:
Set OraRs = Nothing
OraCn.Close
Set OraCn = Nothing
Exit Sub
Err_Han:
MsgBox (Err.Description)
GoTo Obj_Rls
End Sub
Private Sub 大字小字データ登録()
' 国土交通省国土政策局 国土情報課 > 位置参照情報ダウンロードサービス
' http://nlftp.mlit.go.jp/cgi-bin/isj/dls/_view_cities_wards.cgi
' からダウンロードしたCSVファイルより登録する
Const NenDo As String = "_2012" '<-- ダウンロードファイルに合わせて変更する
Dim i As Integer
Dim j As Long
Dim Mst As Adrs3
Dim MySheet As Worksheet
Dim stCd As String
Dim stKenCd As String
Dim stSQL As String
Const stINS3 As String = "INSERT INTO MST_ADRS3(AZACD,KEYKENCD,KEYSIKUCD,KEYOAZACD,KEYKOAZACD,OAZAMEI,KOAZAMEI,HAISIFLG)"
On Err GoTo Err_Han
Call DB_CONNECT
OraCn.BeginTrans
For i = 1 To 47
stKenCd = Format(CStr(i), "00")
If Dir(ThisWorkbook.Path & "\" & stKenCd & NenDo & ".csv", vbNormal) = "" Then
MsgBox (stKenCd & NenDo & ".csvは存在しません！")
GoTo Next_Ken
End If
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & stKenCd & NenDo & ".csv"
Set MySheet = ActiveWorkbook.Worksheets(stKenCd & NenDo)
MySheet.Columns("A:J").Sort key1:=MySheet.Columns(5), order1:=xlAscending, Header:=xlYes
j = 2
Do While Cells(j, 1) <> ""
stCd = Format(Cells(j, 5).Value, "000000000000")
Mst.AzaCd = stCd
Mst.KenCd = Left(stCd, 2)
Mst.SikuCd = Mid(stCd, 3, 3)
Mst.Oazacd = Mid(stCd, 6, 4)
Mst.KoazaCd = Right(stCd, 3)
Mst.HaisiFlg = "0"
If Mst.KoazaCd = "000" Then
Mst.OazaMei = Cells(j, 6).Value
Mst.KoazaMei = ""
Else
If Left(stCd, 9) = Left(Cells(j - 1, 5).Value, 9) Then '一行上と同じ大字か？
Mst.OazaMei = GetOazaMei(j)
Mst.KoazaMei = GetKoazaMei(j)
Else '大字中の最初の小字
Mst.OazaMei = GetOazaMei(j + 1)
Mst.KoazaMei = GetKoazaMei(j + 1)
End If
End If
stSQL = stINS3 & " VALUES('" & Mst.AzaCd & "'," & _
Mst.KenCd & "," & _
Mst.SikuCd & ",'" & _
Mst.Oazacd & "','" & _
Mst.KoazaCd & "','" & _
Mst.OazaMei & "','" & _
Mst.KoazaMei & "','" & _
Mst.HaisiFlg & "')"
Set OraRs = OraCn.Execute(stSQL)
' 次の行へ
j = j + 1
If j = Int(j / 100) * 100 Then
Application.ScreenUpdating = True
Cells(j, 1).Select
Application.ScreenUpdating = False
OraCn.CommitTrans
OraCn.BeginTrans
DoEvents
End If
Loop
Next_Ken:
Next i
Application.ScreenUpdating = True
OraCn.CommitTrans
MsgBox "大字小字テーブル登録終了！"
ActiveWorkbook.Close SaveChanges:=False
Obj_Rls:
Set OraRs = Nothing
OraCn.Close
Set OraCn = Nothing
Exit Sub
Err_Han:
MsgBox (Err.Description)
GoTo Obj_Rls
End Sub
' 大字名取得
Function GetOazaMei(pRow As Long) As String
Dim i As Integer
Dim stAzaMei1 As String: stAzaMei1 = Cells(pRow - 1, 6).Value
Dim stAzaMei2 As String: stAzaMei2 = Cells(pRow, 6).Value
For i = 1 To Len(stAzaMei1)
If Left(stAzaMei1, i) <> Left(stAzaMei2, i) Then
If i = 1 Then
GetOazaMei = ""
Else
GetOazaMei = Left(stAzaMei2, i - 1)
End If
Exit Function
End If
Next i
GetOazaMei = stAzaMei2
End Function
' 小字名取得
Function GetKoazaMei(pRow As Long) As String
Dim i As Integer
Dim stAzaMei1 As String: stAzaMei1 = Cells(pRow - 1, 6).Value
Dim stAzaMei2 As String: stAzaMei2 = Cells(pRow, 6).Value
For i = 1 To Len(stAzaMei1)
If Left(stAzaMei1, i) <> Left(stAzaMei2, i) Then
If i = 1 Then
GetKoazaMei = stAzaMei2
Else
GetKoazaMei = Mid(stAzaMei2, i)
End If
Exit Function
End If
Next i
GetKoazaMei = ""
End Function
Sub 郵便番号更新()
' 住所.jpの住所データCSVを元に郵便番号を更新する
' http://jusyo.jp/csv/new.php
Dim i As Long: i = 2
Dim UpCnt As Long: UpCnt = 0
Dim stOazaMei As String
Dim stKoazaMei As String
Dim iKenCd As Integer
Dim iSikuCd As Integer
Dim vRowId As Variant
Dim stYubin As String
Const stSEL3 As String = "SELECT YUBIN,ROWID FROM MST_ADRS3 WHERE KEYKENCD = "
Const stUPD3 As String = "UPDATE MST_ADRS3 SET YUBIN = '"
Const cCnt As Integer = 10 'コミット間隔
On Err GoTo Err_Han
Call DB_CONNECT
OraCn.BeginTrans
If Dir(ThisWorkbook.Path & "\zenkoku.csv", vbNormal) = "" Then
MsgBox ("zenkoku.csvが存在しません！")
Exit Sub
End If
Workbooks.Open Filename:=ThisWorkbook.Path & "\zenkoku.csv"
Do While Cells(i, 1).Value <> ""
If Cells(i, 5).Value = 1 Or _
Cells(i, 17).Value <> "" Then GoTo Next_Line '一部地域、企業郵便番号は除く
iKenCd = CInt(Cells(i, 2).Value)
iSikuCd = CInt(Right(Cells(i, 3).Value, 3))
stOazaMei = 漢数字化(Trim(Cells(i, 12).Value))
stKoazaMei = 漢数字化(Trim(Cells(i, 16).Value))
stYubin = Cells(i, 5).Value
stSQL = stSEL3 & iKenCd & " AND KEYSIKUCD = " & iSikuCd
If stKoazaMei = "" Then
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI IS NULL"
Else
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI = '" & stKoazaMei & "'"
End If
Set OraRs = OraCn.Execute(stSQL)
If OraRs.EOF And InStr(stOazaMei, "ヶ") > 0 Then
stOazaMei = Replace(stOazaMei, "ヶ", "ケ")
stSQL = stSEL3 & iKenCd & " AND KEYSIKUCD = " & iSikuCd
If stKoazaMei = "" Then
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI IS NULL"
Else
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI = '" & stKoazaMei & "'"
End If
Set OraRs = OraCn.Execute(stSQL)
End If
If OraRs.EOF And InStr(stOazaMei, "ケ") > 0 Then
stOazaMei = Replace(stOazaMei, "ケ", "ヶ")
stSQL = stSEL3 & iKenCd & " AND KEYSIKUCD = " & iSikuCd
If stKoazaMei = "" Then
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI IS NULL"
Else
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI = '" & stKoazaMei & "'"
End If
Set OraRs = OraCn.Execute(stSQL)
End If
If OraRs.EOF And InStr(stOazaMei, "") > 0 Then
stOazaMei = Replace(stOazaMei, "", "塚")
stSQL = stSEL3 & iKenCd & " AND KEYSIKUCD = " & iSikuCd
If stKoazaMei = "" Then
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI IS NULL"
Else
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI = '" & stKoazaMei & "'"
End If
Set OraRs = OraCn.Execute(stSQL)
End If
If OraRs.EOF And InStr(stOazaMei, "塚") > 0 Then
stOazaMei = Replace(stOazaMei, "塚", "")
stSQL = stSEL3 & iKenCd & " AND KEYSIKUCD = " & iSikuCd
If stKoazaMei = "" Then
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI IS NULL"
Else
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI = '" & stKoazaMei & "'"
End If
Set OraRs = OraCn.Execute(stSQL)
End If
If OraRs.EOF And InStr(stOazaMei, "大字") < 1 Then
stOazaMei = "大字" & stOazaMei
stSQL = stSEL3 & iKenCd & " AND KEYSIKUCD = " & iSikuCd
If stKoazaMei = "" Then
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI IS NULL"
Else
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI = '" & stKoazaMei & "'"
End If
Set OraRs = OraCn.Execute(stSQL)
End If
If OraRs.EOF And InStr(stOazaMei, "字") < 1 Then
stOazaMei = "字" & stOazaMei
stSQL = stSEL3 & iKenCd & " AND KEYSIKUCD = " & iSikuCd
If stKoazaMei = "" Then
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI IS NULL"
Else
stSQL = stSQL & " AND OAZAMEI = '" & stOazaMei & "' AND KOAZAMEI = '" & stKoazaMei & "'"
End If
Set OraRs = OraCn.Execute(stSQL)
End If
If OraRs.EOF = False Then
If OraRs.Fields(0) <> stYubin Then
vRowId = OraRs.Fields(1).Value
stSQL = stUPD3 & stYubin & "' WHERE ROWID = '" & vRowId & "'"
Set OraRs = OraCn.Execute(stSQL)
UpCnt = UpCnt + 1
Cells(i, 5).Interior.ColorIndex = 6
Cells(i, 12).Interior.ColorIndex = 6
Cells(i, 16).Interior.ColorIndex = 6
Application.ScreenUpdating = True
Cells(i, 1).Select
Application.ScreenUpdating = False
If UpCnt = Int(UpCnt / cCnt) * cCnt Then
OraCn.CommitTrans
OraCn.BeginTrans
End If
DoEvents
End If
Set OraRs = Nothing
Application.StatusBar = "更新( " & UpCnt & " / " & i - 1 & " 件)"
End If
Next_Line:
i = i + 1
Loop
Application.StatusBar = False
ActiveWorkbook.Close SaveChanges:=False
' Application.ScreenUpdating = True
MsgBox "郵便番号更新終了！ 更新件数:" & UpCnt
Obj_Rls:
OraCn.CommitTrans
OraRs.Close
Set OraRs = Nothing
OraCn.Close
Set OraCn = Nothing
Exit Sub
Err_Han:
MsgBox (Err.Description)
GoTo Obj_Rls
End Sub
' 漢数字化…但し、３桁の数字は未対応
Private Function 漢数字化(pAdrs As String) As String
Dim i As Integer '文字位置
Dim k As Integer '配列添字
Dim kSu As Variant: kSu = Array("〇", "一", "二", "三", "四", "五", "六", "七", "八", "九")
Dim aSu As Variant: aSu = Array("０", "１", "２", "３", "４", "５", "６", "７", "８", "９")
For k = 0 To 9
pAdrs = Replace(pAdrs, aSu(k), kSu(k))
Next k
' 丁目漢数字の10以上編集(十を挿入)
For i = 1 To Len(pAdrs) - 1
If isKNumber(Mid(pAdrs, i, 1)) And _
isKNumber(Mid(pAdrs, i + 1, 1)) Then
If Mid(pAdrs, i + 1, 1) = "〇" Then
pAdrs = Replace(pAdrs, "一〇", "十")
pAdrs = Replace(pAdrs, "〇", "十")
Else
If Mid(pAdrs, i, 1) = "一" Then
pAdrs = Left(pAdrs, i - 1) & "十" & Mid(pAdrs, i + 1)
Else
pAdrs = Left(pAdrs, i) & "十" & Mid(pAdrs, i + 1)
End If
End If
End If
Next i
漢数字化 = pAdrs
End Function
' 漢数字かどうか調べる
Function isKNumber(pMoji As String) As Boolean
Dim i As Integer
Dim kSu As Variant: kSu = Array("〇", "一", "二", "三", "四", "五", "六", "七", "八", "九")
isKNumber = False
For i = 0 To 9
If pMoji = kSu(i) Then
isKNumber = True
Exit For
End If
Next i
End Function
