Attribute VB_Name = "Common_Global_Cache" Option Explicit ' ============================================================ ' Module Name: Global_Cache ' Module Desc: Global Cache Module, Shared caches across all worksheets ' Module Methods: ' - RefreshM1KukanDCache ' - RefreshM2Cache ' - RefreshO1Cache ' ============================================================ Private sheetConfDict As Object Public GlobalCache As Object Public Sub InitCacheManager() If GlobalCache Is Nothing Then Set GlobalCache = CreateObject("Scripting.Dictionary") GlobalCache.CompareMode = vbTextCompare End If End Sub Public Function GetCache(ByVal cacheName As String) As Object Dim cache As Object Dim loadedData As Object ' On Error GoTo RefreshError ' If GlobalCache Is Nothing Then InitCacheManager ' If Not GlobalCache.Exists(cacheName) Then Set GlobalCache(cacheName) = CreateObject("Scripting.Dictionary") GlobalCache(cacheName).CompareMode = vbTextCompare End If Set cache = GlobalCache(cacheName) Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig() If cache.Count = 0 Then If cacheName = "M1KukanDCache" Then Set loadedData = LookupM1KukanCache() ElseIf cacheName = "M2" Then Set loadedData = LookupM2Cache() ElseIf cacheName = "O1" Then Set loadedData = LookupO1Cache() ElseIf Contains(sheetConfDict("Enum"), cacheName) Then Set loadedData = LoadLookup("Enum", cacheName) Else Set loadedData = LoadLookup(cacheName, cacheName) End If If Not loadedData Is Nothing Then Set GlobalCache(cacheName) = loadedData Set cache = loadedData End If End If Set GetCache = cache Exit Function RefreshError: Err.Raise 1001, "GetCache", "Failed to load " & cacheName & " lookup cache: " & Err.Description End Function ' before RefreshCache, should validate Public Sub RefreshCache(ByVal cacheName As String) Dim loadedData As Object ' On Error GoTo RefreshError ' If GlobalCache Is Nothing Then InitCacheManager ' If Not GlobalCache.Exists(cacheName) Then Set GlobalCache(cacheName) = CreateObject("Scripting.Dictionary") GlobalCache(cacheName).CompareMode = vbTextCompare End If Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig() If cacheName = "M1KukanDCache" Then Set loadedData = LookupM1KukanCache() ElseIf cacheName = "M2" Then Set loadedData = LookupM2Cache() ElseIf cacheName = "O1" Then Set loadedData = LookupO1Cache() ElseIf Contains(sheetConfDict("Enum"), cacheName) Then Set loadedData = LoadLookup("Enum", cacheName) Else Set loadedData = LoadLookup(cacheName, cacheName) End If If Not loadedData Is Nothing Then Set GlobalCache(cacheName) = loadedData End If Exit Sub RefreshError: Err.Raise 1001, "RefreshCache", "Failed to load " & cacheName & " lookup cache: " & Err.Description End Sub ' Refresh M1_KukanD cache - nested dict {D: {F: [G]}} ' Structure: { 交通機関区分[D]: { 利用区間発名[F]: [利用区間着名G] } } Private Function LookupM1KukanCache() Dim resultCache As Object Set resultCache = CreateObject("Scripting.Dictionary") On Error GoTo ErrHandler Dim ws As Worksheet On Error Resume Next Set ws = ThisWorkbook.Worksheets("M1") On Error GoTo ErrHandler If ws Is Nothing Then Set LookupM1KukanCache = resultCache Exit Function End If Dim sheetConf As Object: Set sheetConf = sheetConfDict("M1") Dim startRow As Long: startRow = sheetConf("StartRow") Dim lastRow As Long: lastRow = GetLastDataRowInRange(ws) If lastRow < startRow Then Set LookupM2Cache = resultCache Exit Function End If Dim r As Long For r = startRow To lastRow Dim dValue As String: dValue = Trim(ws.Cells(r, 4).Value) ' D column Dim fValue As String: fValue = Trim(ws.Cells(r, 6).Value) ' F column Dim gValue As String: gValue = Trim(ws.Cells(r, 7).Value) ' G column If dValue = "" Or fValue = "" Then GoTo NextRow2 ' Outer level: D column (交通機関区分) If Not resultCache.Exists(dValue) Then Dim innerDict As Object: Set innerDict = CreateObject("Scripting.Dictionary") resultCache.Add dValue, innerDict End If ' Inner level: F column (利用区間発名) -> array of G values Set innerDict = resultCache(dValue) If Not innerDict.Exists(fValue) Then Dim arr As Object: Set arr = CreateObject("Scripting.Dictionary") innerDict.Add fValue, arr End If Set arr = innerDict(fValue) If gValue <> "" And Not arr.Exists(gValue) Then arr.Add gValue, True End If NextRow2: Next r Set LookupM1KukanCache = resultCache Exit Function ErrHandler: Err.Raise Err.Number, Err.Source, Err.Description End Function ' ============================================================ ' M2 Cache - Nested Dictionary ' Structure: { 区間コード[C]: { 券種[I]: { コード[J]: K } } } ' ============================================================ Private Function LookupM2Cache() As Object Dim resultCache As Object Set resultCache = CreateObject("Scripting.Dictionary") On Error GoTo ErrHandler Dim ws As Worksheet On Error Resume Next Set ws = ThisWorkbook.Worksheets("M2") On Error GoTo ErrHandler If ws Is Nothing Then Set LookupM2Cache = resultCache Exit Function End If Dim sheetConf As Object: Set sheetConf = sheetConfDict("M2") Dim startRow As Long: startRow = sheetConf("StartRow") Dim lastRow As Long: lastRow = GetLastDataRowInRange(ws) If lastRow < startRow Then Set LookupM2Cache = resultCache Exit Function End If Dim r As Long For r = startRow To lastRow Dim kukanCode As String: kukanCode = Trim(ws.Cells(r, 3).Value) ' C column Dim kanshu As String: kanshu = Trim(ws.Cells(r, 9).Value) ' I column Dim code As String: code = Trim(ws.Cells(r, 10).Value) ' J column Dim name As String: name = Trim(ws.Cells(r, 11).Value) ' K column If kukanCode = "" Or kanshu = "" Or code = "" Then GoTo NextRow ' Outer level: kukanCode If Not resultCache.Exists(kukanCode) Then Dim innerDict As Object: Set innerDict = CreateObject("Scripting.Dictionary") resultCache.Add kukanCode, innerDict End If ' Middle level: kanshu Set innerDict = resultCache(kukanCode) If Not innerDict.Exists(kanshu) Then Dim innermostDict As Object: Set innermostDict = CreateObject("Scripting.Dictionary") innerDict.Add kanshu, innermostDict End If ' Inner level: code -> name Set innermostDict = innerDict(kanshu) If Not innermostDict.Exists(code) Then innermostDict.Add code, name End If NextRow: Next r Set LookupM2Cache = resultCache Exit Function ErrHandler: Err.Raise Err.Number, Err.Source, Err.Description End Function ' ============================================================ ' O1 Cache ' ============================================================ Private Function LookupO1Cache() As Object Dim resultCache As Object Set resultCache = CreateObject("Scripting.Dictionary") Dim ws As Worksheet On Error Resume Next Set ws = ThisWorkbook.Worksheets("O1") On Error GoTo ErrHandler If ws Is Nothing Then Set LookupO1Cache = resultCache Exit Function End If Dim sheetConf As Object: Set sheetConf = sheetConfDict("O1") Dim startRow As Long: startRow = sheetConf("StartRow") Dim lastRow As Long: lastRow = GetLastDataRowInRange(ws) If lastRow < startRow Then Set LookupO1Cache = resultCache Exit Function End If Dim r As Long For r = startRow To lastRow Dim cVal As String cVal = Trim(ws.Cells(r, 3).Value) ' C column Dim eVal As String eVal = Trim(ws.Cells(r, 5).Value) ' E column Dim fVal As String fVal = Trim(ws.Cells(r, 6).Value) ' F column If cVal = "" Or eVal = "" Then GoTo NextO1 ' Outer: C column If Not resultCache.Exists(cVal) Then Dim innerDict As Object Set innerDict = CreateObject("Scripting.Dictionary") resultCache.Add cVal, innerDict End If ' Inner: E column -> array of F values Set innerDict = resultCache(cVal) If Not innerDict.Exists(eVal) Then Dim arr As Object Set arr = CreateObject("Scripting.Dictionary") innerDict.Add eVal, arr End If Set arr = innerDict(eVal) If Not arr.Exists(fVal) Then arr.Add fVal, True End If NextO1: Next r Set LookupO1Cache = resultCache Exit Function ErrHandler: Err.Raise Err.Number, Err.Source, Err.Description End Function Private Sub RefreshSheetDict() Debug.Print "RefreshSheetDict begin." Set sheetConfDict = CreateObject("Scripting.Dictionary") Dim sheetConf As Object ' C1 Set sheetConf = CreateObject("Scripting.Dictionary") sheetConf("StartCol") = "C" sheetConf("EndCol") = "BC" sheetConf("ErrorCol") = "B" sheetConf("StartRow") = 8 sheetConf("HeaderRow") = 6 sheetConf("CSV_Encoding") = "shift_jis" sheetConf("HasHeader") = True sheetConf("ExpectedColumnCount") = 41 sheetConf("HeaderColumns") = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "W", "X", "Y", "Z", "AD", "AE", "AF", "AG", "AK", "AL", "AM", "AN", "AR", "AS", "AT", "AU", "AV", "AW", "AX", "AY", "AZ", "BA", "BB", "BC") sheetConf("AlwaysQuote") = False sheetConf("FilterRow") = 7 Set sheetConfDict("C1") = sheetConf Debug.Print "RefreshSheetDict C1 ok." ' M1 Set sheetConf = CreateObject("Scripting.Dictionary") sheetConf("StartCol") = "C" sheetConf("EndCol") = "N" sheetConf("ErrorCol") = "B" sheetConf("StartRow") = 7 sheetConf("HeaderRow") = 5 sheetConf("CacheName") = "m1Cache" sheetConf("CSV_Encoding") = "shift_jis" sheetConf("HasHeader") = True sheetConf("ExpectedColumnCount") = 12 sheetConf("HeaderColumns") = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N") sheetConf("AlwaysQuote") = False sheetConf("FilterRow") = 6 sheetConf("KeyCol") = 3 sheetConf("ValueCols") = Array(3, 4, 5, 6, 7, 9, 12) Set sheetConfDict("M1") = sheetConf Debug.Print "RefreshSheetDict M1 ok." ' M2 Set sheetConf = CreateObject("Scripting.Dictionary") sheetConf("StartCol") = "C" sheetConf("EndCol") = "R" sheetConf("ErrorCol") = "B" sheetConf("StartRow") = 8 sheetConf("HeaderRow") = 6 sheetConf("CSV_Encoding") = "shift_jis" sheetConf("HasHeader") = True sheetConf("ExpectedColumnCount") = 11 sheetConf("HeaderColumns") = Array("C", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R") sheetConf("AlwaysQuote") = False sheetConf("FilterRow") = 7 Set sheetConfDict("M2") = sheetConf Debug.Print "RefreshSheetDict M2 ok." ' Z1 Set sheetConf = CreateObject("Scripting.Dictionary") sheetConf("StartCol") = "C" sheetConf("EndCol") = "I" sheetConf("ErrorCol") = "B" sheetConf("StartRow") = 7 sheetConf("HeaderRow") = 5 sheetConf("CSV_Encoding") = "utf-8" sheetConf("HasHeader") = False sheetConf("ExpectedColumnCount") = 7 sheetConf("HeaderColumns") = Array("C", "D", "E", "F", "G", "H", "I") sheetConf("AlwaysQuote") = True sheetConf("FilterRow") = 6 sheetConf("KeyCol") = 3 sheetConf("ValueCols") = Array(4) Set sheetConfDict("Z1") = sheetConf Debug.Print "RefreshSheetDict Z1 ok." ' Z2 Set sheetConf = CreateObject("Scripting.Dictionary") sheetConf("StartCol") = "C" sheetConf("EndCol") = "G" sheetConf("ErrorCol") = "B" sheetConf("StartRow") = 7 sheetConf("HeaderRow") = 5 sheetConf("CSV_Encoding") = "utf-8" sheetConf("HasHeader") = False sheetConf("ExpectedColumnCount") = 5 sheetConf("HeaderColumns") = Array("C", "D", "E", "F", "G") sheetConf("AlwaysQuote") = True sheetConf("FilterRow") = 6 sheetConf("KeyCol") = 3 sheetConf("ValueCols") = Array(4) Set sheetConfDict("Z2") = sheetConf Debug.Print "RefreshSheetDict Z2 ok." ' Z3 Set sheetConf = CreateObject("Scripting.Dictionary") sheetConf("StartCol") = "C" sheetConf("EndCol") = "H" sheetConf("ErrorCol") = "B" sheetConf("StartRow") = 7 sheetConf("HeaderRow") = 5 sheetConf("CSV_Encoding") = "utf-8" sheetConf("HasHeader") = False sheetConf("ExpectedColumnCount") = 6 sheetConf("HeaderColumns") = Array("C", "D", "E", "F", "G", "H") sheetConf("AlwaysQuote") = True sheetConf("FilterRow") = 6 sheetConf("KeyCol") = 3 sheetConf("ValueCols") = Array(4) Set sheetConfDict("Z3") = sheetConf Debug.Print "RefreshSheetDict Z3 ok." ' Z4 Set sheetConf = CreateObject("Scripting.Dictionary") sheetConf("StartCol") = "C" sheetConf("EndCol") = "I" sheetConf("ErrorCol") = "B" sheetConf("StartRow") = 7 sheetConf("HeaderRow") = 5 sheetConf("CSV_Encoding") = "utf-8" sheetConf("HasHeader") = False sheetConf("ExpectedColumnCount") = 7 sheetConf("HeaderColumns") = Array("C", "D", "E", "F", "G", "H", "I") sheetConf("AlwaysQuote") = True sheetConf("FilterRow") = 6 sheetConf("KeyCol") = 3 sheetConf("ValueCols") = Array(4) Set sheetConfDict("Z4") = sheetConf Debug.Print "RefreshSheetDict Z4 ok." ' T1 Set sheetConf = CreateObject("Scripting.Dictionary") sheetConf("StartCol") = "C" sheetConf("EndCol") = "G" sheetConf("ErrorCol") = "B" sheetConf("StartRow") = 7 sheetConf("HeaderRow") = 5 sheetConf("CSV_Encoding") = "utf-8" sheetConf("HasHeader") = False sheetConf("ExpectedColumnCount") = 5 sheetConf("HeaderColumns") = Array("C", "D", "E", "F", "G") sheetConf("AlwaysQuote") = True sheetConf("FilterRow") = 6 sheetConf("KeyCol") = 3 sheetConf("ValueCols") = Array(4) Set sheetConfDict("T1") = sheetConf Debug.Print "RefreshSheetDict T1 ok." ' T2 Set sheetConf = CreateObject("Scripting.Dictionary") sheetConf("StartCol") = "C" sheetConf("EndCol") = "M" sheetConf("ErrorCol") = "B" sheetConf("StartRow") = 7 sheetConf("HeaderRow") = 5 sheetConf("CSV_Encoding") = "utf-8" sheetConf("HasHeader") = False sheetConf("ExpectedColumnCount") = 11 sheetConf("HeaderColumns") = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M") sheetConf("AlwaysQuote") = True sheetConf("FilterRow") = 6 sheetConf("KeyCol") = 3 sheetConf("ValueCols") = Array(4, 6, 8, 9, 10, 11, 12, 13) Set sheetConfDict("T2") = sheetConf Debug.Print "RefreshSheetDict T2 ok." ' T3 Set sheetConf = CreateObject("Scripting.Dictionary") sheetConf("StartCol") = "C" sheetConf("EndCol") = "I" sheetConf("ErrorCol") = "B" sheetConf("StartRow") = 7 sheetConf("HeaderRow") = 5 sheetConf("CSV_Encoding") = "utf-8" sheetConf("HasHeader") = False sheetConf("ExpectedColumnCount") = 7 sheetConf("HeaderColumns") = Array("C", "D", "E", "F", "G", "H", "I") sheetConf("AlwaysQuote") = True sheetConf("FilterRow") = 6 sheetConf("KeyCol") = 3 sheetConf("ValueCols") = Array(4, 8, 9) Set sheetConfDict("T3") = sheetConf Debug.Print "RefreshSheetDict T3 ok." ' O1 Set sheetConf = CreateObject("Scripting.Dictionary") sheetConf("StartCol") = "C" sheetConf("EndCol") = "F" sheetConf("ErrorCol") = "B" sheetConf("StartRow") = 6 sheetConf("HeaderRow") = "5" sheetConf("CSV_Encoding") = "shift_jis" sheetConf("HasHeader") = True sheetConf("ExpectedColumnCount") = 4 sheetConf("HeaderColumns") = Array("C", "D", "E", "F") sheetConf("AlwaysQuote") = True sheetConf("FilterRow") = 5 Set sheetConfDict("O1") = sheetConf Debug.Print "RefreshSheetDict O1 ok." ' O2 Set sheetConf = CreateObject("Scripting.Dictionary") sheetConf("StartCol") = "C" sheetConf("EndCol") = "O" sheetConf("ErrorCol") = "B" sheetConf("StartRow") = 6 sheetConf("HeaderRow") = "5" sheetConf("CSV_Encoding") = "utf-8" sheetConf("HasHeader") = False sheetConf("ExpectedColumnCount") = 13 sheetConf("HeaderColumns") = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O") sheetConf("AlwaysQuote") = True sheetConf("FilterRow") = 5 sheetConf("KeyCol") = 3 sheetConf("ValueCols") = Array(4) Set sheetConfDict("O2") = sheetConf Debug.Print "RefreshSheetDict O2 ok." ' Enum Set sheetConf = Nothing sheetConfDict("Enum") = Array("tokubetuList", "kenshuList", "oufukuList", "koutaiList", "higaitouList", "errorList") Debug.Print "RefreshSheetDict Enum ok." ' tokubetuList Set sheetConf = CreateObject("Scripting.Dictionary") sheetConf("StartRow") = 3 sheetConf("KeyCol") = 1 sheetConf("ValueCols") = Array(1) Set sheetConfDict("tokubetuList") = sheetConf Debug.Print "RefreshSheetDict tokubetuList ok." ' kenshuList Set sheetConf = CreateObject("Scripting.Dictionary") sheetConf("StartRow") = 3 sheetConf("KeyCol") = 3 sheetConf("ValueCols") = Array(4) Set sheetConfDict("kenshuList") = sheetConf Debug.Print "RefreshSheetDict kenshuList ok." ' oufukuList Set sheetConf = CreateObject("Scripting.Dictionary") sheetConf("StartRow") = 3 sheetConf("KeyCol") = 6 sheetConf("ValueCols") = Array(7) Set sheetConfDict("oufukuList") = sheetConf Debug.Print "RefreshSheetDict oufukuList ok." ' koutaiList Set sheetConf = CreateObject("Scripting.Dictionary") sheetConf("StartRow") = 3 sheetConf("KeyCol") = 9 sheetConf("ValueCols") = Array(10) Set sheetConfDict("koutaiList") = sheetConf Debug.Print "RefreshSheetDict koutaiList ok." ' higaitouList Set sheetConf = CreateObject("Scripting.Dictionary") sheetConf("StartRow") = 3 sheetConf("KeyCol") = 12 sheetConf("ValueCols") = Array(13) Set sheetConfDict("higaitouList") = sheetConf Debug.Print "RefreshSheetDict higaitouList ok." ' errorList Set sheetConf = CreateObject("Scripting.Dictionary") sheetConf("StartRow") = 3 sheetConf("KeyCol") = 15 sheetConf("ValueCols") = Array(16) Set sheetConfDict("errorList") = sheetConf Debug.Print "RefreshSheetDict errorList ok." Debug.Print "RefreshSheetDict end." End Sub Public Function GetSheetConfig() As Object If sheetConfDict Is Nothing Then Call RefreshSheetDict Set GetSheetConfig = sheetConfDict End Function Public Function RefreshAllCache() As Boolean ' refresh Dim refreshCacheNames As Variant refreshCacheNames = Array("Z1", "Z2", "Z3", "Z4", "T1", "T2", "T3", "M1", "M1KukanDCache", "M2", "O1","O2", _ "tokubetuList", "kenshuList", "oufukuList", "koutaiList", "higaitouList", "errorList") Dim refreshCacheName As Variant For Each refreshCacheName In refreshCacheNames Call RefreshCache(refreshCacheName) Next refreshCacheName RefreshAllCache = True End Function