Excel VBA | ADOで郵便番号検索を高速化するための「インデックス作成・キャッシュ利用」応用例

Option Explicit

' 郵便番号検索をキャッシュするDictionary
Dim postalCache As Object

Sub InitPostalCache()
    Dim conn As Object, rs As Object
    Dim filePath As String
    
    filePath = "C:\data\KEN_ALL.CSV"
    
    ' キャッシュ用Dictionaryを初期化
    Set postalCache = CreateObject("Scripting.Dictionary")
    
    ' ADO接続
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
              "Data Source=" & Left(filePath, InStrRev(filePath, "\")) & ";" & _
              "Extended Properties=""text;HDR=No;FMT=Delimited"""
    
    ' 郵便番号と住所を全件読み込み（インデックス的に保持）
    Set rs = conn.Execute("SELECT F3, F6, F7, F8 FROM [" & Mid(filePath, InStrRev(filePath, "\") + 1) & "]")
    
    Do Until rs.EOF
        Dim code As String
        code = Replace(rs.Fields(0).Value, "-", "")
        If Not postalCache.Exists(code) Then
            postalCache.Add code, Array(rs.Fields(1).Value, rs.Fields(2).Value, rs.Fields(3).Value)
        End If
        rs.MoveNext
    Loop
    
    rs.Close
    conn.Close
End Sub

Function GetAddressByPostalCode(code As String) As String
    code = Replace(code, "-", "")
    If postalCache.Exists(code) Then
        Dim addrParts As Variant
        addrParts = postalCache(code)
        GetAddressByPostalCode = addrParts(0) & addrParts(1) & addrParts(2)
    Else
        GetAddressByPostalCode = "不明"
    End If
End Function

Sub BatchPostalLookup()
    Dim wsSource As Worksheet, wsResult As Worksheet
    Dim lastRow As Long, i As Long
    
    ' キャッシュ初期化（最初に一度だけ）
    If postalCache Is Nothing Then InitPostalCache
    
    Set wsSource = ThisWorkbook.Sheets("顧客リスト")
    Set wsResult = ThisWorkbook.Sheets("住所結果")
    
    lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
    
    For i = 2 To lastRow
        wsResult.Cells(i, 1).Value = wsSource.Cells(i, 1).Value
        wsResult.Cells(i, 2).Value = GetAddressByPostalCode(wsSource.Cells(i, 1).Value)
    Next i
End Sub

Option Explicit

' 郵便番号検索をキャッシュするDictionary
Dim postalCache As Object

Sub InitPostalCache()
    Dim conn As Object, rs As Object
    Dim filePath As String
    
    filePath = "C:\data\KEN_ALL.CSV"
    
    ' キャッシュ用Dictionaryを初期化
    Set postalCache = CreateObject("Scripting.Dictionary")
    
    ' ADO接続
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
              "Data Source=" & Left(filePath, InStrRev(filePath, "\")) & ";" & _
              "Extended Properties=""text;HDR=No;FMT=Delimited"""
    
    ' 郵便番号と住所を全件読み込み（インデックス的に保持）
    Set rs = conn.Execute("SELECT F3, F6, F7, F8 FROM [" & Mid(filePath, InStrRev(filePath, "\") + 1) & "]")
    
    Do Until rs.EOF
        Dim code As String
        code = Replace(rs.Fields(0).Value, "-", "")
        If Not postalCache.Exists(code) Then
            postalCache.Add code, Array(rs.Fields(1).Value, rs.Fields(2).Value, rs.Fields(3).Value)
        End If
        rs.MoveNext
    Loop
    
    rs.Close
    conn.Close
End Sub

Function GetAddressByPostalCode(code As String) As String
    code = Replace(code, "-", "")
    If postalCache.Exists(code) Then
        Dim addrParts As Variant
        addrParts = postalCache(code)
        GetAddressByPostalCode = addrParts(0) & addrParts(1) & addrParts(2)
    Else
        GetAddressByPostalCode = "不明"
    End If
End Function

Sub BatchPostalLookup()
    Dim wsSource As Worksheet, wsResult As Worksheet
    Dim lastRow As Long, i As Long
    
    ' キャッシュ初期化（最初に一度だけ）
    If postalCache Is Nothing Then InitPostalCache
    
    Set wsSource = ThisWorkbook.Sheets("顧客リスト")
    Set wsResult = ThisWorkbook.Sheets("住所結果")
    
    lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
    
    For i = 2 To lastRow
        wsResult.Cells(i, 1).Value = wsSource.Cells(i, 1).Value
        wsResult.Cells(i, 2).Value = GetAddressByPostalCode(wsSource.Cells(i, 1).Value)
    Next i
End Sub