Files
vba/src/sh/tuk/module/Common_Global_Cache.bas
2026-05-15 15:13:00 +09:00

587 lines
19 KiB
QBasic

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