' 異体字変換
Private Function 異体字(pAdrs As String) As String
' 仕様限界:異体字が2種類以上あるときは、対応できない
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
' 漢数字化…但し、3桁の数字は未対応
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("0", "1", "2", "3", "4", "5", "6", "7", "8", "9")
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 >= "0" And pMoji <= "9" 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
最新の画像もっと見る
最近の「EXCEL VBA」カテゴリーもっと見る
最近の記事
カテゴリー
- VBScript(2)
- Weblog(314)
- お仕事ツール(0)
- Saloon(1099)
- Node.js他(Python)(16)
- HTA(32)
- 決め・分け論(70)
- 映画・ドラマ(37)
- EXCEL VBA(35)
- PL/SQL(10)
- Java(11)
- 詩(自作)(5)
- 詩(塚原将)(298)
- 短歌(200)
- 題詠100首鑑賞(96)
- 題詠100首(109)
- ALIAS SMITH and JONES エピソード(1)
- 題詠100首2010(11)
- 読書(74)
- プロスポーツ(プロ野球、格闘技)(27)
- 日常・育児とか(88)
- 仕事(IT関係)(61)
- とほほ(33)
- 夢(32)
- 勝手にバトン(7)
- 写真(36)
- スタートレック視聴日誌草稿(24)
- 旅行(25)
- 嫌いな言葉(6)
- 好きな言葉(4)
バックナンバー
人気記事