はじめに

住所の都道府県が省略されており、市区町村から始まっている等、都道府県の記載がない住所に都道府県を追加したい場合、市区町村から都道府県を判断し、都道府県を入力することになる。その作業をマクロを使って行い、都道府県の記載がない住所に自動で都道府県を入れる方法を考えたい。また、正確な都道府県・市区町村名かどうかの確認も検討したい。

マクロ作成の経緯

大量の住所データから、都道府県・市区町村名を取得するため、一般的な関数で処理したところ、都道府県名がない、市区町村名の誤字や脱字、合併前の市区町村名、都道府県・市区町村の組み合わせが違うなどが原因で、取得できない、存在しない都道府県・市区町村名が取得されてしまうことがあった。
そのため、そういった住所からでも、正しい都道府県・市区町村名を取得する方法を模索した。

作成したいマクロのイメージ

最新の市区町村と都道府県の組み合わせのリストを作成する。
同名の市区町村がある場合には、市区町村以下の町域で判断する。
同名の市区町村内に同名の町域がある場合は、判断できないため、要確認とする。
作成したリストを使って、市区町村名から都道府県・市区町村名を取得する。
また、大量の住所データを一括して処理したい。

作成したマクロの概要

市区町村と都道府県の組み合わせリストの作成は、郵便番号データを使うことにした。
郵便番号データには、北海道の郡の記載があり、市区町村以下の町域データも取得できる。

上記サイトの「住所の郵便番号（CSV形式）」の「読み仮名データの促音・拗音を小書きで表記するもの」の「全国一括」を使用した。

郵便番号データの「全国地方公共団体コード」については、総務省の「全国地方公共団体コード」仕様を参考にした。

マクロは役割ごとに3つの標準モジュールに分けた。
①Mainモジュール： リストを使って、都道府県・市区町村名を取得する
②FileDownloadモジュール： 郵便番号データをダウンロードする
③CreateListモジュール： 都道府県を取得するための各種リストを作成する

都道府県を取得するために使う各種リストは以下の５つを作成した。
①CityList： 市区町村と都道府県の組み合わせリストの2次元配列
②TownList： 同名の市区町村の町域と都道府県の組み合わせリストの2次元配列
③DupCityDic： 同名の市区町村リストのDictionaryオブジェクト
④DupTownDic： 同名の市区町村内にある同名の町域リストのDictionaryオブジェクト
⑤TypoDic： 「ケ」、「ヶ」の正誤を確認するための誤字用Dictionaryオブジェクト
　

また、大量のデータを処理するため、1件ずつ住所データを市区町村リストから検索していくのではなく、住所データに存在する市区町村を検索ワードとしてリスト化し、その検索ワードで住所データにフィルターをかけ、該当する住所データにまとめて、都道府県・市区町村名を入力するようにした。

動作手順

①Mainモジュール

《PrefNameComplementプロシージャ》

郵便番号データをダウンロード（②FileDownloadモジュール）
各種リストを作成しリストコレクションとして取得（③CreateListモジュール）
処理対象の住所データを配列に入れる
検索用ワードリスト(都道府県・市区町村等のデータと検索ワードの組み合わせ)を作成
　4-1 都道府県+市区町村名、市区町村名の検索ワードを作成
　　（郡がある場合は、都道府県+郡+市区町村名、郡+市区町村名も作成）
　4-2 作成した検索ワードが配列化した住所データにあるか確認
　4-3 検索ワードがある場合、検索ワードリスト用の配列に追加する
検索ワードリストを使って、各検索ワードで住所データにフィルターをかける
（同名の市区町村があり、市区町村名だけでは判断できない場合、町域データを使う）
（同名の市区町村内に同名の町域がある場合、判断できないため「要確認」と入力）
フィルターの結果、該当した住所にまとめて、都道府県・市区町村名を入力する
「ケ」、「ヶ」が間違っている場合、正しい市区町村名を示す
都道府県・市区町村名の該当がなかった住所に「要確認」と入力
「要確認」と入力されたデータのセルを黄色に塗りつぶす
市区町村以下と、都道府県を補完した住所を入力(ComplementAddressプロシージャ)
※ComplementAddressプロシージャについての説明は割愛

②FileDownloadモジュール

《宣言セクション》

ファイルダウンロード用のAPI宣言をモジュールの一番先頭の宣言セクション内に記載

　
《PostcodeZipFileDownloadプロシージャ》

ダウンロードURLからダウンロードするファイル名を取得し、保存ファイルパスを作成
念のため、キャッシュをクリアする
指定したファイルをダウンロードする
ダウンロードしたZip解凍するため、PowerShell用のコマンドを作成する
PowerShellのコマンドを実行する

③CreateListモジュール

《宣言セクション》

列挙型のEnumを使って郵便番号データの列番号を定義
Mainモジュールで使うリストを渡すため、各リストをモジュールレベル変数で宣言

　
《GetListCollection関数プロシージャ》

各リストをコレクションとして渡す関数プロシージャ

項目番号と項目名のコレクションを作成するプロシージャ（SetListNo）を呼び出す
市区町村リストを作成するプロシージャ（CreateCityList）を呼び出す
町域リストを作成するプロシージャ（CreateTownList）を呼び出す
作成したリストをコレクションに追加して、戻り値とする

　
《SetListNoプロシージャ》

CityList、TownListの項目番号と項目名を組み合わせたコレクションを作成
（Mainプロシージャで配列となているリストを使う際に、項目名が分かるように作成）

《CreateCityListプロシージャ》

FileSystemObjectのTextStream使って郵便番号データのCSVを1行ずつ読込
市区町村、同名の市区町村用のDictionaryオブジェクトを作成
全国地方公共団体コードの後ろから3つ目の数字を基に市区町村を3つに分類
政令指定都市、政令指定都市以外の市、町村別にデータを加工
（CSVデータの市区町村欄は、郡+町村、政令指定市+行政区となっているため分割）
加工したデータをコレクションに追加し、データ一式を作成
加工したデータを市区町村と都道府県の組み合わせリスト用の配列に入れる
同名の市区町村を探すため、市区町村用Dictionaryに市区町村名をキーにデータを追加
同名の市区町村の場合、同名の市区町村用Dictionaryにデータを追加
（都道府県+郡+市区町村+行政区をキーにデータを追加）
「ケ」「ヶ」を含む、都道府県・郡、市区町村名がある場合、誤字用Dictionaryに追加
（誤字をキーに、正しい名称と誤字のコレクションを追加）

　
《CreateTownListプロシージャ》

FileSystemObjectのTextStream使って郵便番号データのCSVを1行ずつ読込
町域用のDictionaryオブジェクトを作成
同名の市区町村用Dictionaryに存在する市区町村の町域リストを作成する
3-1 町域と都道府県の組み合わせリスト用の配列にデータを入れる
3-2 同名の町域を探すため、町域用Dictionaryに市区町村名+町域名をキーにして追加
3-3 同名の町域の場合、同名の町域リスト用Dictionaryに市区町村+*+町域をキーに追加

その他コメント

マクロ内ですべて完結させるため、長いコードとなっており、そのため、処理にも時間がかかるが、毎回、郵便番号データをダウンロードしてリストを作るより、エクセル内の別シートに、あらかじめ郵便番号データから各種リストを作成しておき、それを読み込んで処理すれば、処理速度が速くなると思う
CityList、TownList、SearchList用の項目番号と項目名のコレクションは、不要かとも思ったが、コードの分かりやすさを優先するため、使用することにした

完成したマクロ

前提として、「作業シート」のA列に処理対象の住所データを記載。
B列以降に処理後の各データを出力する。
また、処理状況をステータスバーに表示させている。

作業シートのイメージ

サンプルの住所データは、EDINETコードリストから、内国法人・組合の住所を抜き出した。
（このデータの住所の大部分が市区町村からで、都道府県が抜けているため、苦労した。）

①Mainモジュール

①Mainモジュール

Public Sub PrefNameComplement()

Dim TargetUrl As String
Dim PostcodeFileName As String
Dim i As Long
Dim j As Long
Dim k As Long

Dim ListCollection As Collection
Dim CityList() As String
Dim TownList() As String
Dim CityListNo As Collection
Dim TownListNo As Collection
Dim DupCityDic As Object
Dim DupTownDic As Object
Dim TypoDic As Object

Dim TargetSheet As Worksheet
Dim endRow As Long
Dim OutputRange As Range
Dim AddressList() As String
Dim SearchList()  As String
Dim SearchListCount As Long
Dim SearchListNo As Collection
Dim SearchWord() As String
Dim SearchFlag() As Boolean
Dim SearchTownName As String

    TargetUrl = "https://www.post.japanpost.jp/zipcode/dl/kogaki/zip/ken_all.zip"
    PostcodeFileName = "KEN_ALL.CSV"
    
    Application.StatusBar = "データをダウンロード中です..."
    Call PostcodeZipFileDownload(TargetUrl, PostcodeFileName)

    Application.StatusBar = "市区町村リスト・町域リストを作成中です..."    
    Set ListCollection = New Collection
    Set ListCollection = GetListCollection(PostcodeFileName)   
    CityList = ListCollection("CityList")
    TownList = ListCollection("TownList")
    Set CityListNo = ListCollection("CityListNo")
    Set TownListNo = ListCollection("TownListNo")
    Set DupTownDic = ListCollection("DupTownDic")
    Set DupCityDic = ListCollection("DupCityDic")
    Set TypoDic = ListCollection("TypoDic")
    Set ListCollection = Nothing

    Application.StatusBar = "検索用ワードリストを作成中です..."
    Set TargetSheet = ThisWorkbook.Sheets("作業シート")
    endRow = TargetSheet.Cells(Rows.Count, "A").End(xlUp).Row

    ReDim AddressList(2 To endRow)    
    For i = 2 To endRow   
        AddressList(i) = TargetSheet.Cells(i, "A").Value
    Next i
  
    Set SearchListNo = CityListNo
    SearchListNo.Add 7, "SearchWord"   

    For i = 0 To UBound(CityList, 2)        
        ReDim SearchWord(1)         
        SearchWord(0) = CityList(CityListNo("PrefCityName"), i)
        SearchWord(1) = CityList(CityListNo("CityName"), i)    

        If CityList(CityListNo("AreaName"), i) <> "" Then
            ReDim Preserve SearchWord(3)
            SearchWord(2) = CityList(CityListNo("PrefAreaCityName"), i)
            SearchWord(3) = CityList(CityListNo("AreaCityName"), i)
        End If 
        
        ReDim SearchFlag(UBound(SearchWord))  
        
        For j = 0 To UBound(SearchFlag)
            SearchFlag(j) = False
        Next j
 
        For j = 0 To UBound(SearchWord)  
            k = 2
            Do
                If AddressList(k) Like SearchWord(j) & "*" Then
                    SearchFlag(j) = True
                End If
                If k = UBound(AddressList) Then Exit Do
                k = k + 1
            Loop Until SearchFlag(j)
        Next j

        For j = 0 To UBound(SearchWord)
            If SearchFlag(j) Then
                ReDim Preserve SearchList(UBound(CityList, 1) + 1, SearchListCount)
                For k = 0 To UBound(CityList, 1)
                    SearchList(k, SearchListCount) = CityList(k, i)
                Next k
                SearchList(SearchListNo("SearchWord"), SearchListCount) = SearchWord(j)
                SearchListCount = SearchListCount + 1
            End If
        Next j
    Next i
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
  
    TargetSheet.Range("A1").CurrentRegion.Interior.Color = xlNone
    If Not TargetSheet.AutoFilter Is Nothing Then TargetSheet.Range("A1").AutoFilter   
    TargetSheet.Range("A1").CurrentRegion.Offset(1, 1).ClearContents
    
    For i = 0 To UBound(SearchList, 2)
        With TargetSheet
            Select Case True
                '検索ワードが市区町村名で重複市区町村名に該当する場合は町域で検索
                Case SearchList(SearchListNo("SearchWord"), i) = SearchList(SearchListNo("CityName"), i) _
                        And DupCityDic.Exists(SearchList(SearchListNo("PrefAreaCityName"), i))
                
                    For j = 0 To UBound(TownList, 2)
                        If TownList(TownListNo("CityName"), j) = SearchList(SearchListNo("CityName"), i) Then
                            '市区町村名と町域名の間に「大字」が入る可能性があるため、「*」で繋げている
                            SearchTownName = TownList(TownListNo("CityName"), j) & "*" & TownList(TownListNo("TownName"), j)
                        
                            Select Case True
                                Case DupTownDic.Exists(SearchTownName)
                                    If WorksheetFunction.CountIf(.Columns("A:A"), SearchTownName & "*") > 0 Then
                                        .Range("A1").AutoFilter Field:=1, Criteria1:=SearchTownName & "*"
                                        Set OutputRange = .Range(.Range("B2"), .Cells(endRow, "B"))
                                        OutputRange.SpecialCells(xlCellTypeVisible).Value = "★同名の町域があるため要確認★"
                                        Set OutputRange = Nothing
                                        .Range("A1").AutoFilter
                                    End If
                                Case Else
                                    If WorksheetFunction.CountIf(.Columns("A:A"), SearchTownName & "*") > 0 Then                         
                                        .Range("A1").AutoFilter Field:=1, Criteria1:=SearchTownName & "*"
                                        For k = 0 To 3
                                            Set OutputRange = .Range(.Cells(2, k + 2), .Cells(endRow, k + 2))
                                            OutputRange.SpecialCells(xlCellTypeVisible).Value = TownList(k, j)
                                            Set OutputRange = Nothing
                                        Next k
                                        .Range("A1").AutoFilter
                                    End If
                            End Select
                                
                        End If
                    Next j
                
                Case Else
                    .Range("A1").AutoFilter Field:=1, Criteria1:=SearchList(UBound(SearchList, 1), i) & "*"
                    For j = 0 To 3
                        Set OutputRange = .Range(.Cells(2, j + 2), .Cells(endRow, j + 2))
                        OutputRange.SpecialCells(xlCellTypeVisible).Value = SearchList(j, i)
                        Set OutputRange = Nothing
                    Next j
                    
                    .Range("A1").AutoFilter
            End Select   
        End With
        Application.StatusBar = i & "/" & UBound(SearchList, 2) & "件目を検索中です..."
    Next i
 
    Application.StatusBar = "リストを処理中です..."
    
    With TargetSheet  
        For i = 0 To TypoDic.Count - 1            
            If WorksheetFunction.CountIf(.Range(.Range("A2"), .Cells(endRow, "A")), "*" & TypoDic.Items()(i)("TypoName") & "*") > 0 Then  
                .Range("A1").AutoFilter Field:=1, Criteria1:="*" & TypoDic.Items()(i)("TypoName") & "*"
                Set OutputRange = .Range(.Range("B2"), .Cells(endRow, "B"))
                OutputRange.SpecialCells(xlCellTypeVisible).Value = "★" & TypoDic.Items()(i)("CorrectName") & "が正式名称です" & "★"
                Set OutputRange = Nothing
                .Range("A1").AutoFilter 
            End If
        Next i

        If WorksheetFunction.CountIf(.Range(.Range("B2"), .Cells(endRow, "B")), "") > 0 Then
            .Range("A1").AutoFilter Field:=2, Criteria1:=""
            Set OutputRange = .Range(.Range("B2"), .Cells(endRow, "B"))
            OutputRange.SpecialCells(xlCellTypeVisible).Value = "★該当するデータがないため要確認★"
            Set OutputRange = Nothing
            .Range("A1").AutoFilter
        End If
 
        If WorksheetFunction.CountIf(.Range(.Range("B2"), .Cells(endRow, "B")), "★*") > 0 Then
            .Range("A1").AutoFilter Field:=2, Criteria1:="★*"
            Set OutputRange = .Range(.Range("A2"), .Cells(endRow, "A"))
            OutputRange.SpecialCells(xlCellTypeVisible).Interior.Color = vbYellow
            Set OutputRange = Nothing
            .Range("A1").AutoFilter
        End If
        
        Call ComplementAddress(TargetSheet)

        .Range("A1").AutoFilter
    
    End With
    
    Set TargetSheet = Nothing
    Application.StatusBar = False
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub


Public Sub ComplementAddress(TargetSheet As Worksheet)

Dim endRow As Long
Dim ReplaceAddress As String
Dim FullAddress As String
Dim i As Long
Dim j As Long

    endRow = TargetSheet.Cells(Rows.Count, "A").End(xlUp).Row
    
    With TargetSheet
        For i = 2 To endRow
            If .Cells(i, "C").Value <> "" Then
            
                ReplaceAddress = .Cells(i, "A").Value
                For j = 3 To 5
                    ReplaceAddress = Replace(ReplaceAddress, .Cells(i, j).Value, "")
                Next j
                .Cells(i, "F").Value = ReplaceAddress
                
                FullAddress = ""
                For j = 3 To 6
                    FullAddress = FullAddress & .Cells(i, j).Value
                Next j
                .Cells(i, "G").Value = FullAddress
            End If
        Next i 
    End With

End Sub

②FileDownloadモジュール

②FileDownloadモジュール

'ファイルダウンロード API宣言
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

'キャッシュ削除 API宣言
Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "wininet" Alias "DeleteUrlCacheEntryA" _
(ByVal lpszUrlName As String) As Long


Public Sub PostcodeZipFileDownload(TragetURL As String, PostcodeFileName As String)

Dim iFlag As Long
Dim SaveFilePath As String
Dim SaveFileName As String
Dim psCommand As String
Dim Wsh As Object

    SaveFileName = Right(TragetURL, Len(TragetURL) - InStrRev(TragetURL, "/"))
    SaveFilePath = ThisWorkbook.Path & "\" & SaveFileName
    
    Call DeleteUrlCacheEntry(TragetURL) 'キャッシュクリア
    iFlag = URLDownloadToFile(0, TragetURL, SaveFilePath, 0, 0)
    If iFlag <> 0 Then MsgBox "ダウンロード失敗": End
  
    psCommand = "powershell -NoProfile -ExecutionPolicy Unrestricted Expand-Archive -Path " & SaveFilePath & " -DestinationPath " & ThisWorkbook.Path & " -Force"
    Set Wsh = CreateObject("WScript.Shell")
    iFlag = Wsh.Run(Command:=psCommand, WindowStyle:=0, WaitOnReturn:=True)
    If iFlag <> 0 Then MsgBox "Zip解凍失敗": End
    Set Wsh = Nothing
    
End Sub

③CreateListモジュール

③CreateListモジュール

'郵便番号データファイルの列番号
Private Enum CSVColumnNo
    CityCode = 1
    PrefName = 7
    CityName = 8
    TownName = 9
End Enum

Private CityList() As String
Private TownList() As String
Dim CityListNo As Collection
Dim TownListNo As Collection
Private DupTownDic As Object
Private DupCityDic As Object
Private TypoDic As Object
Private ListNo As Collection

Public Function GetListCollection(PostcodeFileName As String) As Collection

    Call SetListNo  
    Call CreateCityList(PostcodeFileName)
    Call CreateTownList(PostcodeFileName) 
    
    Set GetListCollection = New Collection
    GetListCollection.Add CityList, "CityList"
    GetListCollection.Add TownList, "TownList"
    GetListCollection.Add CityListNo, "CityListNo"
    GetListCollection.Add TownListNo, "TownListNo"
    GetListCollection.Add DupTownDic, "DupTownDic"
    GetListCollection.Add DupCityDic, "DupCityDic"
    GetListCollection.Add TypoDic, "TypoDic"
    
End Function


Private Sub SetListNo()

Dim i As Long
Dim ItemNameArray As Variant
    
    Set CityListNo = New Collection
    ItemNameArray = Array("CityCode", "PrefName", "AreaName", "CityName", "PrefAreaCityName", "AreaCityName", "PrefCityName")
    For i = 0 To UBound(ItemNameArray) 
        CityListNo.Add i, ItemNameArray(i)
    Next i

    Set TownListNo = New Collection
    ItemNameArray = Array("CityCode", "PrefName", "AreaName", "CityName", "TownName")
    For i = 0 To UBound(ItemNameArray)
        TownListNo.Add i, ItemNameArray(i)
    Next i

End Sub

Private Sub CreateCityList(PostcodeFileName As String)

Dim FSO As Object
Dim TextFile As Object
Dim SplitData As Variant
Dim i As Long

Dim CityListSet As Collection
Dim CityCode As String
Dim PrefName As String
Dim BaseCityName As String
Dim CityName As String
Dim AreaName As String
Dim TypoName As String
Dim AddItem As Collection
Dim BeforePrefAreaCityName As String
Dim CityCount As Long
Dim CityDic As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set TextFile = FSO.OpenTextFile(ThisWorkbook.Path & "\" & PostcodeFileName)
   
    CityCount = 0
    Set CityDic = CreateObject("Scripting.Dictionary")
    Set DupCityDic = CreateObject("Scripting.Dictionary")
    Set TypoDic = CreateObject("Scripting.Dictionary")
    
    Do   
        SplitData = Split(TextFile.ReadLine, ",")
        CityCode = Replace(SplitData(CSVColumnNo.CityCode - 1), """", "")
        PrefName = Replace(SplitData(CSVColumnNo.PrefName - 1), """", "")
        BaseCityName = Replace(SplitData(CSVColumnNo.CityName - 1), """", "")

        Select Case Val(Left(Right(CityCode, 3), 1))
            
            Case 1 '全国地方公共団体コード 後ろから3つ目が100～199⇒政令指定都市(行政区あり)
                AreaName = ""
                If PrefName = "東京都" Then
                    CityName = BaseCityName  
                Else
                   CityName = Left(BaseCityName, InStr(BaseCityName, "市"))
                   '行政区の地方公共団体コードを市の地方公共団体コードに変換
                    If Val(Left(Right(CityCode, 3), 1)) = 1 Then
                        CityCode = Left(CityCode, Len(CityCode) - 1) & "0"
                    End If
                End If
            
            Case 2 '全国地方公共団体コード 後ろから3つ目が200～299⇒市（政令指定都市以外）
                AreaName = ""
                CityName = BaseCityName

            Case Is >= 3 '全国地方公共団体コード 後ろから3つ目が300以上⇒町村（郡あり）
                AreaName = Left(BaseCityName, InStr(BaseCityName, "郡"))
                CityName = Replace(BaseCityName, AreaName, "")
            
        End Select
  
        Set CityListSet = New Collection        
        CityListSet.Add CityCode, "CityCode"
        CityListSet.Add PrefName, "PrefName"
        CityListSet.Add AreaName, "AreaName"
        CityListSet.Add CityName, "CityName"
        CityListSet.Add PrefName & AreaName & CityName, "PrefAreaCityName"
        CityListSet.Add AreaName & CityName, "AreaCityName"
        CityListSet.Add PrefName & CityName, "PrefCityName"
        
        If CityListSet("PrefAreaCityName") <> BeforePrefAreaCityName Then
            
            ReDim Preserve CityList(CityListSet.Count - 1, CityCount)
            For i = 0 To UBound(CityList, 1)
                CityList(i, CityCount) = CityListSet(i + 1)
            Next i
 
           If Not CityDic.Exists(CityName) Then
                CityDic.Add CityName, CityListSet
            Else
                If Not DupCityDic.Exists(CityDic(CityName)("PrefAreaCityName")) Then
                    DupCityDic.Add CityDic(CityName)("PrefAreaCityName"), CityDic(CityName)
                End If 
                DupCityDic.Add CityListSet("PrefAreaCityName"), CityListSet
            End If

            For i = 2 To 4
                Select Case True
                    Case CityListSet(i) Like "*ケ*"
                        TypoName = Replace(CityListSet(i), "ケ", "ヶ")
                    Case CityListSet(i) Like "*ヶ*"
                        TypoName = Replace(CityListSet(i), "ヶ", "ケ")
                    Case Else
                        TypoName = ""
                End Select
                
                If TypoName <> "" Then
                    If TypoDic.Exists(CityListSet(i)) Then
                        TypoDic.Remove CityListSet(i)
                    Else
                        If Not TypoDic.Exists(TypoName) Then
                            Set AddItem = New Collection
                            AddItem.Add CityListSet(i), "CorrectName"
                            AddItem.Add TypoName, "TypoName"
                            TypoDic.Add TypoName, AddItem
                            Set AddItem = Nothing
                        End If  
                    End If  
                End If 
            Next i

            BeforePrefAreaCityName = CityListSet("PrefAreaCityName")
            CityCount = CityCount + 1
            Set CityListSet = Nothing
        End If   
    Loop Until TextFile.AtEndOfLine
    
    Set CityDic = Nothing
    Set TextFile = Nothing
    Set FSO = Nothing

End Sub


Private Sub CreateTownList(PostcodeFileName As String)

Dim FSO As Object
Dim TextFile As Object
Dim SplitData As Variant
Dim i As Long

Dim TownDic As Object
Dim PrefName As String
Dim BaseCityName As String
Dim CityName As String
Dim TownName As String
Dim TownListSet As Collection
Dim TownCount As Long
Dim DupTownCount As Long

    TownCount = 0
    DupTownCount = 0
    
    Set TownDic = CreateObject("Scripting.Dictionary")
    Set DupTownDic = CreateObject("Scripting.Dictionary")
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set TextFile = FSO.OpenTextFile(ThisWorkbook.Path & "\" & PostcodeFileName)
   
    Do
        SplitData = Split(TextFile.ReadLine, ",")
        PrefName = Replace(SplitData(CSVColumnNo.PrefName - 1), """", "")
        BaseCityName = Replace(SplitData(CSVColumnNo.CityName - 1), """", "")
        
        If DupCityDic.Exists(PrefName & BaseCityName) Then 
        
            CityName = DupCityDic(PrefName & BaseCityName)("CityName")
            TownName = Replace(SplitData(CSVColumnNo.TownName - 1), """", "") 
            
            If TownName <> "以下に掲載がない場合" Then
                If Not TownDic.Exists(CityName & TownName) Then
                    Set TownListSet = New Collection
                    TownListSet.Add DupCityDic(PrefName & BaseCityName)("CityCode"), "CityCode"
                    TownListSet.Add PrefName, "PrefName"
                    TownListSet.Add DupCityDic(PrefName & BaseCityName)("AreaName"), "AreaName"
                    TownListSet.Add DupCityDic(PrefName & BaseCityName)("CityName"), "CityName"
                    TownListSet.Add TownName, "TownName"
                    
                    ReDim Preserve TownList(4, TownCount)
                    For i = 0 To 4
                        TownList(i, TownCount) = TownListSet(i + 1)   
                    Next i
                    TownDic.Add CityName & TownName, CityName & TownName
                    TownCount = TownCount + 1
                    Set TownListSet = Nothing    
                Else
                    DupTownDic.Add CityName & "*" & TownName, CityName & "*" & TownName
                    DupTownCount = DupTownCount + 1 
                End If  
             End If 
             
        End If
     Loop Until TextFile.AtEndOfLine

     Set TownDic = Nothing
     Set TextFile = Nothing
     Set FSO = Nothing

End Sub

サンプルファイル保存先：