住所分解コード化ツール…後半

' http://blog.goo.ne.jp/frontflug/e/3ae75689d27e9048f055decfb01114fa より続く

' 異体字変換
Private Function 異体字(pAdrs As String) As String
' 仕様限界：異体字が２種類以上あるときは、対応できない
　 Dim k　　As Integer '配列添字
　 Dim Pat1 As String: Pat1 = "ヶッ塚斎檜與澤櫻嵩圓應參實釋條眞數淺曾臺邊槇籔藪豫"
　 Dim Pat2 As String: Pat2 = "ケツ斉桧与沢桜高円応参実釈条真数瀬浅曽台辺槙薮薮予"
　 Dim Mae　As String

　 Mae = pAdrs
　 For k = 1 To Len(Pat1)
　　　pAdrs = Replace(pAdrs, Mid(Pat1, k, 1), Mid(Pat2, k, 1))
　 Next k
　 If Mae = pAdrs Then
　　　For k = 1 To Len(Pat2)
　　　　 pAdrs = Replace(pAdrs, Mid(Pat2, k, 1), Mid(Pat1, k, 1))
　　　Next k
　 End If
　 異体字 = pAdrs
End Function

' 漢数字化…但し、３桁の数字は未対応
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 isNumber(pMoji As String) As Boolean
　 If isANumber(pMoji) Or isKNumber(pMoji) Then
　　　isNumber = True
　 Else
　　　isNumber = False
　 End If
End Function

' 全角アラビア数字かどうか調べる
Function isANumber(pMoji As String) As Boolean
　 If pMoji >= "０" And pMoji <= "９" Then
　　　isANumber = True
　 Else
　　　isANumber = False
　 End If
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

' 番地文字かどうか調べる
Function isBanti(pMoji As String) As Boolean
　 Dim i　 As Integer: i = 2

　 isBanti = False
　 Do While Sheets("番地文字").Cells(i, 1).Value <> ""
　　　If pMoji = Sheets("番地文字").Cells(i, 1).Value Then
　　　　 isBanti = True
　　　　 Exit Do
　　　End If
　　　i = i + 1
　 Loop
End Function

' 政令指定都市都道府県名省略
Private Sub Edit_Kenmei(pRow As Integer)
　 Dim stAdrs As String: stAdrs = Cells(pRow, 11).Value

　 If InStr(Cells(pRow, 11).Value, "北海道") > 0 Then
　　　Cells(pRow, 11).Value = Replace(stAdrs, "北海道", "")
　　　Exit Sub
　 End If
　
　 If InStr(Cells(pRow, 11).Value, "東京都") > 0 Then
　　　Cells(pRow, 11).Value = Replace(stAdrs, "東京都", "")
　　　Exit Sub
　 End If

　 If InStr(Cells(pRow, 11).Value, "京都府") > 0 Then
　　　Cells(pRow, 11).Value = Replace(stAdrs, "京都府", "")
　　　Exit Sub
　 End If

　 If InStr(Cells(pRow, 11).Value, "大阪府") > 0 Then
　　　Cells(pRow, 11).Value = Replace(stAdrs, "大阪府", "")
　　　Exit Sub
　 End If
　
　 If Mid(stAdrs, 3, 1) = "県" Then
　　　Cells(pRow, 11).Value = Mid(stAdrs, 4)
　　　Exit Sub
　 ElseIf Mid(stAdrs, 4, 1) = "県" Then
　　　Cells(pRow, 11).Value = Mid(stAdrs, 5)
　　　Exit Sub
　 End If
　
End Sub

' ADO : ORACLE DB 接続
Private Sub DB_CONNECT()
　 If Not OraCn Is Nothing Then Exit Sub

　 On Err GoTo Err_Han
　 Dim stPass As String

' パスワードの設定
　 stPass = Sheets("USER").Cells(4, 2).Value
　 If stPass = "" Then
　　　stPass = InputBox("USER:" & Sheets("USER").Cells(3, 2).Value & "のPassWord？")
　　　If stPass = "" Then
　　　　 Exit Sub
　　　End If
　 End If

' ORACLE接続
　 Set OraCn = CreateObject("ADODB.Connection")
　 OraCn.Open "Provider=MSDAORA;Data Source=(DESCRIPTION=(ADDRESS_LIST=(ADDRESS=" & _
　　　　　　　"(PROTOCOL=TCP)(HOST=" & Sheets("USER").Cells(1, 2).Value & ")(PORT = 1521)))" & _
　　　　　　　"(CONNECT_DATA=(SID=" & Sheets("USER").Cells(2, 2).Value & ")));", _
　　　　　　　Sheets("USER").Cells(3, 2).Value, stPass

　 Exit Sub
Err_Han:
　 OraCn.Close
　 Set OraCn = Nothing
　 MsgBox (Err.Description)
　 Sheets("ADRS_LIST").Select
End Sub

' シート字情報の設定
Private Sub 字情報取得()
　　
　 Dim stSQL　As Variant
　 Dim i　　　As Integer　'行
　 Dim j　　　As Integer
　
　 Sheets("字情報").Select
　 If Cells(1, 2).Value = "" Then
　　　Cells(1, 2).Select
　　　MsgBox ("都道府県コードを指定して下さい！")
　　　Exit Sub
　 End If
　 If Cells(2, 2).Value = "" Then
　　　Cells(2, 2).Select
　　　MsgBox ("市区町村コードを指定して下さい！")
　　　Exit Sub
　 End If

　 Range("A6:E6").Select
　 Range(Selection, Selection.End(xlDown)).Select
　 Selection.ClearContents
　 Range("A6").Select

　 Call DB_CONNECT
　 stSQL = "SELECT A1.KENMEI || A2.SIKUMEI FROM CCTM_ADRS1 A1,MST_ADRS2 A2"
　 stSQL = stSQL & " WHERE A1.KEYKENCD = A2.KEYKENCD AND A2.KEYKENCD = " & Cells(1, 2).Value
　 stSQL = stSQL & " AND A2.KEYSIKUCD = " & Cells(2, 2).Value & " AND A2.HAISIFLG = 0"
　 Set OraRs = OraCn.Execute(stSQL)
　 i = 6
　 If OraRs.EOF Then
　　　MsgBox ("存在しない市区町村コードです！")
　　　GoTo AZA_SET_EXIT
　 End If
　 Cells(3, 2).Value = OraRs.Fields(0).Value　　　　 ' 都道府県名+市区町村名
　 OraRs.Close
　 Set OraRs = Nothing

　 stSQL = "SELECT OAZAMEI,KOAZAMEI,YUBIN,OAZACD,KOAZACD FROM MST_ADRS3"
　 stSQL = stSQL & " WHERE KEYKENCD = " & Cells(1, 2).Value
　 stSQL = stSQL & " AND KEYSIKUCD = " & Cells(2, 2).Value
　 stSQL = stSQL & " AND HAISIFLG = 0 ORDER BY OAZACD,KOAZACD"
　 Set OraRs = OraCn.Execute(stSQL)
　 i = 6
　 Do While Not OraRs.EOF
　　　Cells(i, 1).Value = OraRs.Fields(0).Value　　　' 大字名
　　　Cells(i, 2).Value = OraRs.Fields(1).Value　　　' 小字名
　　　Cells(i, 3).Value = OraRs.Fields(2).Value　　　' 郵便番号
　　　Cells(i, 4).Value = OraRs.Fields(3).Value　　　' 大字コード
　　　Cells(i, 5).Value = OraRs.Fields(4).Value　　　' 小字コード
　　　OraRs.MoveNext
　　　i = i + 1
　 Loop

AZA_SET_EXIT:
　 OraRs.Close
　 Set OraRs = Nothing
　 OraCn.Close
　 Set OraCn = Nothing

　 MsgBox ("字情報取得終了！")
　 Cells(4, 1).Select

End Sub