| |
自分の勉強の為、作ってみました。
Dic_MakeでWorkSheets("住所Dic")を作ったあとに
分割するモジュールを２つ作ってみました
'郵政の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
|
|
ハチ
- 06/8/2(水) 19:34 -
