| |
あるキャンペーンで顧客に紹介する店の住所を、システムに登録しています。
その際下記マクロで住所を住所１〜４にわけています。
例１：千葉県一川市妙典1-2まち田マンション203 ⇒「千葉県」「一川市」「妙典」「1-2まち田マンション203」（正しい）
ところがうまくいかないことがあります。
例２：千葉県市川市妙典1-2町田マンション203 ⇒「千葉県」「市」「川市」「妙典1-2町田マンション203」（ダメ）
例３：千葉県一川市妙典1-2町田マンション203 ⇒「千葉県」「一川市」「妙典1-2町」「田マンション203」（ダメ）
例２の場合は住所２が市川市に、例３の場合は住所３が「妙典」になるようにするにはどこをどう改善すればよいでしょうか。
'カウンタ
Dim i As Long
Dim iCnt As Long
Dim iCnt1 As Long
Dim iCnt2 As Long
Dim iCnt3 As Long
Dim iCnt4 As Long
Dim Saisyuu_gyou As Long ' １項目の住所のデータ件数
Dim Gyou As Long ' １項目の住所の行番号
Dim Retu As String ' １項目の住所の列番号
Dim Retub As Long ' １項目住所の列番号（数値）
Dim c
Dim Kennsaku_moji As String ' 検索する文字（都道府県）
Dim Kennsaku_moji1 As String ' 検索する文字（市区郡）
Dim Kennsaku_moji2 As String ' 検索する文字（区町村）
Dim Kennsaku_moji3 As String ' 検索する文字（地名・字名）
Dim Kennsaku_moji4 As String ' 検索する文字（番地）
Dim v As Long ' 文字位置（番地）
Dim w As Long ' 文字位置（番地）最小値
Dim x As Long ' 文字位置（都道府県）
Dim y As Long ' 文字位置（市区郡）
Dim z As Long ' 文字位置（市区郡２）
'*************************************************
' 住所データから４項目住所データに分割する。
'*************************************************
Sub 分割start()
Module1.Juusyo_bunnkatu
MsgBox "住所分割、処理終了しました。"
End Sub
'*************************************
' 都道府県の確定
'*************************************
Sub Juusyo_bunnkatu()
Sheets("住所入力シート").Activate
'----１セル（行）の処理 ------------------------------
Gyou = 2
Retu = "a" ' １項目住所の列番号（文字）
Retub = 1 ' １項目住所の列番号（数値） ------- retuとretubとは、連動させること。
Saisyuu_gyou = Range(Retu & Gyou).CurrentRegion.Rows.Count
For i = Gyou To Saisyuu_gyou + Gyou
x = 0
y = 0
z = 0
w = 0
v = 0
For iCnt = 1 To 5
If iCnt = 1 Then Kennsaku_moji = "県"
If iCnt = 2 Then Kennsaku_moji = "府" '京都府の場合、都を左記に検索処理すると京都で区切るので、
If iCnt = 3 Then Kennsaku_moji = "都" '先に府で検索処理させる。
If iCnt = 4 Then Kennsaku_moji = "道"
If iCnt = 5 Then
x = 0
Module1.Juusyo_set1 '市区郡へ
Else
x = InStr(Range(Retu & Gyou), Kennsaku_moji)
If x > 0 Then
Module1.Juusyo_set1 '市区郡へ
Exit For
End If
End If
Next
Module1.Sheet_Set 'シートに反映
Gyou = Gyou + 1
Next
Module1.Kana_Set
End Sub
'*************************************
' 市区郡の確定
'*************************************
Sub Juusyo_set1()
' ---- 第2検索文字での検索・処理 ----------------
For iCnt1 = 1 To 6
If iCnt1 = 1 Then Kennsaku_moji1 = "市"
If iCnt1 = 2 Then Kennsaku_moji1 = "区"
If iCnt1 = 3 Then Kennsaku_moji1 = "郡"
If iCnt1 = 4 Then Kennsaku_moji1 = "町"
If iCnt1 = 5 Then Kennsaku_moji1 = "村"
If iCnt1 = 6 Then
Exit For
Else
y = InStr(x + 1, Range(Retu & Gyou), Kennsaku_moji1)
If y > 0 Then
Module1.Juusyo_set2 '区町村へ
Exit For
End If
End If
Next
End Sub
'*************************************
' 区町村の確定
'*************************************
Sub Juusyo_set2()
' ---- 第3検索文字での検索・処理 ----------------
For iCnt2 = 1 To 6
If iCnt2 = 1 Then Kennsaku_moji2 = "市"
If iCnt2 = 2 Then Kennsaku_moji2 = "区"
If iCnt2 = 3 Then Kennsaku_moji2 = "町"
If iCnt2 = 4 Then Kennsaku_moji2 = "村"
'If iCnt2 = 5 Then Kennsaku_moji2 = "郡"
If iCnt2 = 5 Then
z = y
If z > 0 Then
Module1.Juusyo_set3
Exit For
End If
Else
z = InStr(y + 1, Range(Retu & Gyou), Kennsaku_moji2)
If z > 0 Then
Module1.Juusyo_set3
Exit For
End If
End If
Next
End Sub
'*************************************
' 地名・字名の確定
'*************************************
Sub Juusyo_set3()
For iCnt3 = 1 To 9
'半角数字
Kennsaku_moji3 = Trim(Str(iCnt3))
v = InStr(z + 1, Range(Retu & Gyou), Kennsaku_moji3)
If v = 0 Then
'全角数字
Kennsaku_moji3 = Trim(StrConv(Str(iCnt3), vbWide))
v = InStr(z + 1, Range(Retu & Gyou), Kennsaku_moji3)
End If
If v <> 0 Then
If w = 0 Or w > v Then
w = v
End If
End If
Next
End Sub
'*************************************
' 分割した住所をシートに反映
'*************************************
Sub Sheet_Set()
If x > 0 Then
Cells(Gyou, Retub + 1) = Mid(Range(Retu & Gyou), 1, x)
End If
If y > 0 Then
Cells(Gyou, Retub + 2) = Mid(Range(Retu & Gyou), x + 1, y - x)
End If
If z > 0 Then
If y = z And w > 0 Then
Cells(Gyou, Retub + 4) = Mid(Range(Retu & Gyou), y + 1, (w - 1) - y)
Cells(Gyou, Retub + 6) = Mid(Range(Retu & Gyou), w, Len(Range(Retu & Gyou)) - (w - 1))
Else
Cells(Gyou, Retub + 4) = Mid(Range(Retu & Gyou), y + 1, z - y)
Cells(Gyou, Retub + 6) = Mid(Range(Retu & Gyou), z + 1, Len(Range(Retu & Gyou)) - z)
End If
End If
End Sub
'*************************************
' カナの設定
'*************************************
Sub Kana_Set()
'最終行
Selection.SpecialCells(xlCellTypeLastCell).Select
endr = ActiveCell.Row
'-------------------
'セル列のカナ設定
'-------------------
'市区郡
Range(Cells(1, 3), Cells(endr, 3)).SetPhonetic
Range(Cells(1, 3), Cells(endr, 3)).Select
Selection.Phonetics.CharacterType = xlKatakana
'区町村
Range(Cells(1, 5), Cells(endr, 5)).SetPhonetic
Range(Cells(1, 5), Cells(endr, 5)).Select
Selection.Phonetics.CharacterType = xlKatakana
'地名・字名・番地
Range(Cells(1, 7), Cells(endr, 7)).SetPhonetic
Range(Cells(1, 7), Cells(endr, 7)).Select
Selection.Phonetics.CharacterType = xlKatakana
'-------------------
'フリカナの入力
'-------------------
'市区郡
Range(Cells(1, 4), Cells(endr, 4)).Formula = "=PHONETIC(c1)"
Range("c1").Select
'区町村
Range(Cells(1, 6), Cells(endr, 6)).Formula = "=PHONETIC(e1)"
Range("e1").Select
'地名・字名・番地
Range(Cells(1, 8), Cells(endr, 8)).Formula = "=PHONETIC(g1)"
Range("g1").Select
End Sub
|
|
にしもり
- 06/4/18(火) 14:54 -
