| |
もう解決となっておりますが・・
なんとなく納得がいかず、さらにイヂっていました。
ファイルサイズもコンパクトになりました。
'郵政の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
|
|
ハチ
- 06/8/3(木) 19:54 -
