Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


44812 / 76735 ←次へ | 前へ→

【36934】住所をうまく切るには
質問  にしもり  - 06/4/18(火) 14:54 -

引用なし
パスワード
   あるキャンペーンで顧客に紹介する店の住所を、システムに登録しています。
その際下記マクロで住所を住所1〜4にわけています。
例1:千葉県一川市妙典1-2まち田マンション203 ⇒「千葉県」「一川市」「妙典」「1-2まち田マンション203」(正しい)

ところがうまくいかないことがあります。
例2:千葉県市川市妙典1-2町田マンション203 ⇒「千葉県」「市」「川市」「妙典1-2町田マンション203」(ダメ)
例3:千葉県一川市妙典1-2町田マンション203 ⇒「千葉県」「一川市」「妙典1-2町」「田マンション203」(ダメ)

例2の場合は住所2が市川市に、例3の場合は住所3が「妙典」になるようにするにはどこをどう改善すればよいでしょうか。


'カウンタ
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   ' 1項目の住所のデータ件数
Dim Gyou      As Long   ' 1項目の住所の行番号
Dim Retu      As String  ' 1項目の住所の列番号
Dim Retub      As Long   ' 1項目住所の列番号(数値)
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         ' 文字位置(市区郡2)

'*************************************************
' 住所データから4項目住所データに分割する。
'*************************************************
Sub 分割start()

  Module1.Juusyo_bunnkatu
  MsgBox "住所分割、処理終了しました。"

End Sub

'*************************************
' 都道府県の確定
'*************************************
Sub Juusyo_bunnkatu()

Sheets("住所入力シート").Activate

'----1セル(行)の処理 ------------------------------

Gyou = 2
Retu = "a"   ' 1項目住所の列番号(文字)
Retub = 1    ' 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

1 hits

【36934】住所をうまく切るには にしもり 06/4/18(火) 14:54 質問
【36935】Re:住所をうまく切るには neptune 06/4/18(火) 15:06 回答
【36936】Re:住所をうまく切るには にしもり 06/4/18(火) 15:12 お礼
【36941】Re:住所をうまく切るには neptune 06/4/18(火) 17:38 回答
【36961】Re:住所をうまく切るには クロ 06/4/19(水) 9:25 回答
【36979】Re:住所をうまく切るには にしもり 06/4/19(水) 12:20 質問
【36981】Re:住所をうまく切るには neptune 06/4/19(水) 12:55 回答
【36987】Re:住所をうまく切るには にしもり 06/4/19(水) 13:50 お礼
【36988】Re:住所をうまく切るには にしもり 06/4/19(水) 13:54 質問
【36989】Re:住所をうまく切るには にしもり 06/4/19(水) 13:58 お礼
【37011】Re:住所をうまく切るには クロ 06/4/19(水) 19:01 回答
【37043】Re:住所をうまく切るには にしもり 06/4/20(木) 9:02 お礼

44812 / 76735 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free