Excel VBA質問箱 IV

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

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


40591 / 76732 ←次へ | 前へ→

【41237】Re:住所の分割方法
発言  ハチ  - 06/8/2(水) 19:34 -

引用なし
パスワード
   自分の勉強の為、作ってみました。
Dic_MakeでWorkSheets("住所Dic")を作ったあとに
分割するモジュールを2つ作ってみました

'郵政のKEN_ALL.CSVからWorkSheets("住所Dic")を生成する。
Sub Dic_Make()

Dim Ken, Sicho As String
Dim R, c As Long
Dim buf() As String
Dim myPath As String
Dim CSVFile As String
Dim FSO As Object
Dim Ws As Worksheet

myPath = ThisWorkbook.Path
CSVFile = "\KEN_ALL.CSV"

If Dir(myPath & CSVFile) = "" Then
  MsgBox CSVFile & "がありません": Exit Sub
End If
For Each Ws In ThisWorkbook.Worksheets
  If Ws.Name = "住所Dic" Then
    Ws.Cells.ClearContents
    Exit For
  End If
Next Ws
If Ws Is Nothing Then
  With ThisWorkbook
    Set Ws = .Worksheets.Add(After:=Worksheets(.Worksheets.Count))
    Ws.Name = "住所Dic"
  End With
End If

Set FSO = CreateObject("Scripting.FileSystemObject")

Application.ScreenUpdating = False
R = 0: c = 0
With FSO.GetFile(myPath & CSVFile).OpenAsTextStream
  Do Until .AtEndOfStream = True
    buf = Split(.ReadLine, ",")
    If Ken <> buf(6) Then
      Ken = buf(6)
      R = 1: c = c + 1
      Ws.Cells(R, c).Value = Replace(Ken, """", "")
    End If
    
    If Sicho <> buf(7) Then
      Sicho = buf(7)
      R = R + 1
      Ws.Cells(R, c).Value = Replace(Sicho, """", "")
    End If
  Loop
  .Close
End With
Application.ScreenUpdating = True
Set Ws = Nothing
Set FSO = Nothing

MsgBox "住所Dicが作成されました"

End Sub

'→方向に県をループして一致したら↓方向に市をループ
'県が省略されると分割できない。例)横浜市港南区・・・など
Sub Like_BUNKATU()

Dim Wr As Variant  '書き出し用Array
Dim R, Tgt As Range 'ループ用,対象セル
Dim Ken_Ran, Sicho_Ran As Range '県Range,対象県の市町村Range
Dim Ken, Sicho As String '県,市町村
Dim DataSh As Worksheet 'データSheet
Dim DicSh As Worksheet '辞書Sheet

For Each DicSh In ThisWorkbook.Worksheets
  If DicSh.Name = "住所Dic" Then Exit For
Next DicSh
If DicSh Is Nothing Then MsgBox "住所Dicがありません": Exit Sub

Set DataSh = ThisWorkbook.Worksheets(1)
Set Ken_Ran = Range(DicSh.Range("A1"), DicSh.Range("A1").End(xlToRight))

Application.ScreenUpdating = False
For Each Tgt In Range(DataSh.Range("A1"), DataSh.Range("A65536").End(xlUp))
  For Each R In Ken_Ran
    If Tgt.Value Like R.Value & "*" Then
      Ken = R.Value
      Exit For
    End If
  Next R
  If IsEmpty(R) = False Then
    Set Sicho_Ran = Range(DicSh.Cells(2, R.Column), _
     DicSh.Cells(2, R.Column).End(xlDown))
    For Each R In Sicho_Ran
      If Tgt.Value Like Ken & R.Value & "*" Then
        Sicho = R.Value
        Wr = Array(Ken, Sicho, Mid(Tgt.Value, Len(Ken) + Len(Sicho) + 1))
        Tgt.Offset(, 1).Resize(, 3) = Wr
        Exit For
      End If
    Next R
  End If
Next Tgt

Application.ScreenUpdating = True
Set Ken_Ran = Nothing
Set Sicho_Ran = Nothing
Set DicSh = Nothing
Set DataSh = Nothing
Erase Wr

MsgBox "終了"

End Sub


'Len_min〜Len_max数で切り出しFindを繰り返して分割。
'県を省略しても分割されるが、県+市が間違っていても分割される
'例)青森県横浜市港南区・・など
Sub Find_BUNKATU()

Dim Wr() As String '書き出し用Array
Dim Tgt As Range '対象セル
Dim Fi As Variant '検索
Dim Cnt, En, i As Integer '分割数,対象文字数,カウンタ
Dim buf, Ken, Sicho As String '一時文字列,県,市町村
Dim DataSh As Worksheet 'データSheet
Dim DicSh As Worksheet '辞書Sheet
Const Len_min As Integer = 2 '最小分割文字数 例)港区,呉市
Const Len_max As Integer = 10 '最大分割文字数 例)南都留郡富士河口湖町

For Each DicSh In ThisWorkbook.Worksheets
  If DicSh.Name = "住所Dic" Then Exit For
Next DicSh
If DicSh Is Nothing Then MsgBox "住所Dicがありません": Exit Sub
Set DataSh = ThisWorkbook.Worksheets(1)

Application.ScreenUpdating = False
For Each Tgt In Range(DataSh.Range("A1"), DataSh.Range("A65536").End(xlUp))
  ReDim Wr(2)
  buf = Tgt.Value
  For Cnt = 1 To 2
    If Len(buf) > Len_max Then
      En = Len_max
    Else
      En = Len(buf)
    End If
    For i = Len_min To En
      Set Fi = DicSh.UsedRange.Find(Left(buf, i), , , xlWhole, , , False, False)
      If Not Fi Is Nothing Then
        If Fi.Row = 1 Then
          Wr(0) = Fi.Value
        Else
          Wr(1) = Fi.Value
        End If
        buf = Mid(buf, i + 1)
        Exit For
      End If
    Next i
  Next Cnt
  Wr(2) = buf
  Tgt.Offset(, 1).Resize(, 3) = Wr
Next Tgt

Application.ScreenUpdating = True

Set DicSh = Nothing
Set DataSh = Nothing
Erase Wr

MsgBox "終了"

End Sub

'おまけ
Sub test()

Dim min, max As Integer
Dim minStr, maxStr As String
Dim R As Range
min = 3
For Each R In Worksheets("住所Dic").UsedRange
  If min > Len(R.Value) And Len(R.Value) <> 0 Then min = Len(R.Value)
  If max < Len(R.Value) Then max = Len(R.Value)
Next R

Debug.Print "min=" & min
Debug.Print "max=" & max

For Each R In Worksheets("住所Dic").UsedRange
  If Len(R.Value) = min Then Debug.Print R.Value
  If Len(R.Value) = max Then Debug.Print R.Value
Next R
End Sub

0 hits

【41140】住所の分割方法 pi 06/7/31(月) 18:30 質問
【41142】Re:住所の分割方法 ponpon 06/7/31(月) 19:26 発言
【41198】Re:住所の分割方法 pi 06/8/1(火) 18:05 質問
【41149】Re:住所の分割方法 inoue 06/7/31(月) 22:36 発言
【41200】Re:住所の分割方法 pi 06/8/1(火) 18:10 質問
【41233】Re:住所の分割方法 角田 06/8/2(水) 18:04 回答
【41157】Re:住所の分割方法 m2m10 06/8/1(火) 8:25 発言
【41201】Re:住所の分割方法 pi 06/8/1(火) 18:15 質問
【41225】Re:住所の分割方法 neptune 06/8/2(水) 14:17 回答
【41363】Re:住所の分割方法 m2m10 06/8/7(月) 15:06 発言
【41367】Re:住所の分割方法 neptune 06/8/7(月) 18:35 発言
【41204】Re:住所の分割方法 ハチ 06/8/1(火) 19:56 発言
【41237】Re:住所の分割方法 ハチ 06/8/2(水) 19:34 発言
【41284】Re:住所の分割方法 ハチ 06/8/3(木) 19:54 発言
【41227】Re:住所の分割方法 m2m10 06/8/2(水) 15:04 発言
【41273】Re:住所の分割方法 pi 06/8/3(木) 16:07 お礼
【41278】Re:住所の分割方法 neptune 06/8/3(木) 16:55 発言
【41289】Re:住所の分割方法 toshi 06/8/3(木) 21:27 質問
【41290】Re:住所の分割方法 neptune 06/8/3(木) 22:38 発言
【41292】Re:住所の分割方法 ハチ 06/8/3(木) 23:43 発言
【41291】Re:住所の分割方法 漂流民 06/8/3(木) 23:22 発言
【41294】Re:住所の分割方法 toshi 06/8/4(金) 0:00 質問
【41295】Re:住所の分割方法 toshi 06/8/4(金) 0:50 質問
【41296】Re:住所の分割方法 toshi 06/8/4(金) 1:31 お礼
【41372】Re:住所の分割方法 漂流民 06/8/7(月) 23:35 発言

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