Excel VBA質問箱 IV

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

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


40548 / 76736 ←次へ | 前へ→

【41284】Re:住所の分割方法
発言  ハチ  - 06/8/3(木) 19:54 -

引用なし
パスワード
   もう解決となっておりますが・・
なんとなく納得がいかず、さらにイヂっていました。
ファイルサイズもコンパクトになりました。


'郵政のKEN_ALL.CSVからWorkSheets("住所Dic")を生成する。
'_2では除外リストへ再整形
Sub Dic_Make_2()

Dim Ken, Sicho As String '県,市町村
Dim R, c As Long '書き出し用Row,Column
Dim buf As Variant '一時的な配列
Dim myPath As String '取り込みファイルPath
Dim CSVFile As String '取り込みファイル名
Dim FSO As Object 'Scripting.FileSystemObject
Dim Ws As Worksheet '対象WorkSheet
Dim min, max As Integer '分割文字文字列数
Dim Tgt As Range '対象セル ループ用
Dim Str As String '切り出し文字列
Dim myDic As Object 'dictionary

myPath = ThisWorkbook.Path
CSVFile = "\KEN_ALL.CSV"
'取り込みファイルがあるか判定
If Dir(myPath & CSVFile) = "" Then
  MsgBox CSVFile & "がありません": Exit Sub
End If
'WorkSheets("住所Dic")があるか判定。なければ作成
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
Set FSO = Nothing

'以下_2にて追加
'−−−−−−−
Set myDic = CreateObject("Scripting.dictionary")
min = 3
'取り込んだデータをループ Tgt
For Each Tgt In Ws.UsedRange
  '最小、最大文字数の作成
  If min > Len(Tgt.Value) And Len(Tgt.Value) <> 0 Then min = Len(Tgt.Value)
  If max < Len(Tgt.Value) Then max = Len(Tgt.Value)
  '文字列途中に分割文字があるか判定
  If Tgt.Value Like "*[都道府県区市町村]?*" Then
    'あれば一文字ずらし分割して判定
    For i = 2 To Len(Tgt.Value) - 1
      Str = Left(Tgt.Value, i)
      '分割文字列の位置であるか判定
      If Str Like "*[都道府県区市町村]" Then
        '重複の判定。.Add 〜の値はなんでも良い
        If myDic.Exists(Str) = False Then myDic.Add Str, 1
      End If
    Next i
  End If
Next Tgt
'重複の無い文字列の取り出し
buf = myDic.Keys
'Wsのデータを削除し、取り出した文字列の書き込み
Ws.Cells.Delete
For i = 0 To UBound(buf)
  Ws.Range("A1").Offset(i).Value = buf(i)
Next i

Application.ScreenUpdating = True
MsgBox "住所Dicが作成されました" & vbCr _
& "Macth_BUNKATU()内を" & vbCr _
& "Const Len_min As Integer = " & min & vbCr _
& "Const Len_max As Integer = " & max & vbCr _
& "に設定してください"

Set myDic = Nothing
Set Ws = Nothing
Erase buf
End Sub


'−−−−−−−−−−−−−
'分割文字列で判定。
'住所Dicを除外リストとして使用する。
Sub Macth_BUNKATU()

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

'WorkSheets("住所Dic")があるか判定。なければ、Exit Sub
For Each DicSh In ThisWorkbook.Worksheets
  If DicSh.Name = "Sheet3" Then Exit For
Next DicSh
If DicSh Is Nothing Then MsgBox "住所Dicがありません": Exit Sub
Set DataSh = ThisWorkbook.Worksheets(1)

Application.ScreenUpdating = False

'分割対象範囲をループ Tgt
For Each Tgt In Range(DataSh.Range("A1"), DataSh.Range("A65536").End(xlUp))
  '書き出し配列を初期化
  ReDim Wr(2)
  '対象セルの文字列を取得 buf
  buf = Tgt.Value
  '県、市、その後の分割用にループ2回 Cnt
  For Cnt = 1 To 2
    '最大分割数を下回った場合の処理。文字列分割ループ数をEnへ
    If Len(buf) > Len_max Then
      En = Len_max
    Else
      En = Len(buf)
    End If
    '分割文字数のループ i
    For i = Len_min To En
      'i文字分をStrへ
      Str = Left(buf, i)
      '区切り文字[都道府県区市町村]か判定
      If Str Like "*[都道府県区市町村]" Then
        '区切り文字であった場合、除外リストDicShにあるか判定
        Ma = Application.Match(Str, DicSh.UsedRange, 0)
        If IsError(Ma) = True Then
          '県or市の判定。Falseなら市
          If Str Like "*[都道府県]" Then
            Wr(0) = Str
          Else
            Wr(1) = Str
          End If
          'buf文字列から切り出し分を削除
          buf = Mid(buf, i + 1)
          Exit For
        End If
      End If
    Next i
    '県が省略されていた場合、Cntループは1回で終了
    If Cnt = 1 And Wr(0) = "" Then Exit For
  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

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 発言

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