20260515指摘対応6

This commit is contained in:
guanxiangwei
2026-05-20 18:46:15 +09:00
parent b25db7d99c
commit 5b4ffe87aa
18 changed files with 259 additions and 185 deletions
+86 -104
View File
@@ -1,11 +1,24 @@
Attribute VB_Name = "Common_Button"
Option Explicit
' --- Public Variables ---
Public lastErrorMsg As String
' ============================================================
' Module Name: Common_Button
' Module Desc: Common_Button
' Module Desc: Common Button handlers with centralized error handling
' Module Methods:
' - CSV_Import_Button
' - Validation_Button
' - CSV_Export_Button
' - Sort_Button
' - Filter_Button
' - Fit_Button
' - RefreshCache_Button
' ============================================================
' --- Public Button Functions ---
Sub CSV_Import_Button()
DO_CSV_Import ActiveSheet
End Sub
@@ -54,7 +67,6 @@ Sub RefreshCache_Button()
Call RefreshMasterCache()
Debug.Print "3. Determine which cache sheets to refresh based on ActiveSheet"
Dim refSheets As Variant
If activeSheetName = "C1" Then
' first is M1
Call ValidateKukanCache("M1")
@@ -77,43 +89,22 @@ Sub RefreshCache_Button()
ErrorHandler:
HandleError "RefreshCache_Button"
If exitMsg <> "" Then
MsgBox "RefreshCache_Button: " & exitMsg, vbExclamation
Else
MsgBox "RefreshCache_Button: " & Err.Description, vbExclamation
End If
End Sub
Private Sub ValidateKukanCache(ByVal sheetName As String)
On Error GoTo ErrorHandler
Dim exitMsg As String
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(CStr(sheetName))
Dim result As Long: result = RunValidationSilent(ws)
If result = 0 Then
exitMsg = sheetName & " sheet has no data."
GoTo ErrorHandler
Err.Raise ERR_CACHE_EMPTY, "ValidateKukanCache", sheetName & " sheet has no data."
End If
If result < 0 Then
exitMsg = "Can't refresh " & sheetName & " cache. Validation error occurs."
GoTo ErrorHandler
End If
Exit Sub
ErrorHandler:
If exitMsg <> "" Then
MsgBox "ValidateKukanCache: " & exitMsg, vbExclamation
Else
MsgBox "ValidateKukanCache: " & Err.Description, vbExclamation
If result = -1 Then
Err.Raise ERR_VALIDATION_FAILED, "ValidateKukanCache", "Validation error in " & sheetName & " sheet."
End If
End Sub
Private Sub UpdateByMaster(ByVal sheetName As String)
On Error GoTo ErrorHandler
Dim exitMsg As String
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(CStr(sheetName))
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
@@ -121,19 +112,13 @@ Private Sub UpdateByMaster(ByVal sheetName As String)
Dim startRow As Long: startRow = sheetConf("StartRow")
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws)
Application.Run sheetName & ".Refresh", ws, startRow, lastDataRow
Exit Sub
ErrorHandler:
If exitMsg <> "" Then
MsgBox "UpdateByMaster: " & exitMsg, vbExclamation
Else
MsgBox "UpdateByMaster: " & Err.Description, vbExclamation
End If
End Sub
' ============================================================
' CSV Import with error handler
' ============================================================
Private Sub DO_CSV_Import(ws As Excel.Worksheet)
On Error GoTo ImportError
On Error GoTo ErrorHandler
' Step 1: get csv encoding
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
@@ -147,71 +132,61 @@ Private Sub DO_CSV_Import(ws As Excel.Worksheet)
' Step 3: Read CSV and return 2D array
Dim csvData As Variant: csvData = ReadCSVAs2DArrayStrict(filePath, expectedColumnCount, cfg("CSV_Encoding"), cfg("HasHeader"))
If Not IsArray(csvData) Then
MsgBox "No valid data returned from CSV.", vbExclamation
GoTo FinallyExit
If Not IsArray(csvData) Or UBound(csvData, 1) < 1 Then
Err.Raise ERR_FILE_EMPTY, "DO_CSV_Import", "No data in CSV."
End If
If UBound(csvData, 1) < 1 Then
MsgBox "No data in CSV.", vbExclamation
GoTo FinallyExit
End If
' === Step 3:Clear all data rows before import ===
' === Step 4: Clear all data rows before import ===
Application.ScreenUpdating = False
Application.EnableEvents = False
Call ClearDataRows(ws)
' === Step 4: Write CSV data to worksheet ===
' === Step 5: Write CSV data to worksheet ===
Dim colLetters As Variant: colLetters = cfg("HeaderColumns")
Dim writeRow As Long: writeRow = cfg("StartRow")
Dim i As Long
' loop row
For i = LBound(csvData, 1) To UBound(csvData, 1)
Dim j As Long
' loop column
For j = 0 To expectedColumnCount - 1
ws.Cells(writeRow, ws.Range(colLetters(j) & "1").Column).Value = CleanCSVField(CStr(csvData(i, j + 1)))
Next j
writeRow = writeRow + 1
Next i
' === Step 5: Trigger sheet-specific import handler ===
If ProcedureExists(ws.CodeName, "ImportCSVAndTriggerChange") Then
Call Application.Run(ws.CodeName & ".ImportCSVAndTriggerChange", ws, writeRow)
End If
MsgBox writeRow - cfg("StartRow") & " rows imported.", vbInformation
GoTo FinallyExit
ImportError:
MsgBox "CSV import failed: " & Err.Description, vbExclamation
ErrorHandler:
HandleError "DO_CSV_Import"
GoTo FinallyExit
FinallyExit:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
'
' ============================================================
' Do_Validation with HandleError
' ============================================================
Private Sub Do_Validation(ws As Excel.Worksheet)
On Error GoTo ErrorHandler
Dim exitMsg As String
Dim result As Long: result = RunValidationSilent(ws)
If result = -1 Then
exitMsg = "Validation has errors."
GoTo ErrorHandler
ElseIf result = 0 Then
exitMsg = "No data to validate."
GoTo ErrorHandler
Else
If ws.CodeName <> "C1" Then
RefreshCache(ws.CodeName)
WriteCachesSheet(ws.CodeName)
End If
MsgBox "Validation complete. Success: " & result, vbInformation
Err.Raise ERR_VALIDATION_FAILED, "Do_Validation", "Validation has errors."
End If
If result = 0 Then
Err.Raise ERR_CACHE_EMPTY, "Do_Validation", "No data to validate."
End If
If ws.CodeName <> "C1" Then
RefreshCache(ws.CodeName)
WriteCachesSheet(ws.CodeName)
End If
MsgBox "Validation complete. Success: " & result, vbInformation
' step2. ValidateWarn for M1 sheet
If ws.CodeName = "M1" Then
@@ -220,33 +195,27 @@ Private Sub Do_Validation(ws As Excel.Worksheet)
End If
Do_Fit ws
Exit Sub
ErrorHandler:
HandleError "Do_Validation"
' If exitMsg <> "" Then
' MsgBox "Do_Validation: " & exitMsg, vbExclamation
' Else
' MsgBox "Do_Validation: " & Err.Description, vbExclamation
' End If
End Sub
'
' ============================================================
' CSV Export with HandleError
' ============================================================
Private Sub DO_CSV_Export(ws As Excel.Worksheet)
On Error GoTo ExportError
On Error GoTo ErrorHandler
' === Step 1: Validate all rows before export ===
Dim result As Long: result = RunValidationSilent(ws)
If result = 0 Then
MsgBox "No data rows to output.", vbExclamation
Exit Sub
Err.Raise ERR_CACHE_EMPTY, "DO_CSV_Export", "No data rows to output."
End If
If result < 0 Then
MsgBox "Validation failed. Export aborted.", vbCritical
Exit Sub
Err.Raise ERR_VALIDATION_FAILED, "DO_CSV_Export", "Validation failed. Export aborted."
End If
' === Step 2: Select save path ===
@@ -269,7 +238,6 @@ Private Sub DO_CSV_Export(ws As Excel.Worksheet)
Dim dataRow As Long: dataRow = 1
Dim outputArr As Variant
' when has header + 1
If hasHeader Then
ReDim outputArr(1 To rowCount + 1, 1 To expectedColumnCount)
Else
@@ -292,22 +260,23 @@ Private Sub DO_CSV_Export(ws As Excel.Worksheet)
Dim r As Long
For r = startRow To lastDataRow
For colIdx = 0 To expectedColumnCount - 1
outputArr(dataRow, colIdx + 1) = CleanCSVField(ws.Cells(r, Columns(colLetters(colIdx)).Column).Value)
outputArr(dataRow, colIdx + 1) = CleanCSVField(ws.Cells(r, Columns(colLetters(colIdx))).Column).Value)
Next colIdx
dataRow = dataRow + 1
Next r
On Error GoTo ExportError
Call WriteCSVFromArray(savePath, outputArr, sheetConf("CSV_Encoding"), sheetConf("AlwaysQuote"))
On Error GoTo 0
MsgBox "CSV export completed. Total data rows: " & rowCount, vbInformation
Exit Sub
ExportError:
MsgBox "CSV export failed: " & Err.Description, vbExclamation
ErrorHandler:
HandleError "DO_CSV_Export"
End Sub
' ============================================================
' Do_Sort with HandleError
' ============================================================
Private Sub Do_Sort(ws As Excel.Worksheet)
On Error GoTo ErrorHandler
@@ -320,8 +289,7 @@ Private Sub Do_Sort(ws As Excel.Worksheet)
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws)
If lastDataRow < startRow Then
MsgBox "No data to sort.", vbExclamation
Exit Sub
Err.Raise ERR_CACHE_EMPTY, "Do_Sort", "No data to sort."
End If
Dim sortRange As Range: Set sortRange = ws.Range(ws.Cells(startRow, ws.Range(startCol & "1").Column), ws.Cells(lastDataRow, ws.Range(endCol & "1").Column))
@@ -332,9 +300,12 @@ Private Sub Do_Sort(ws As Excel.Worksheet)
Exit Sub
ErrorHandler:
MsgBox "Error: " & Err.Description, vbCritical
HandleError "Do_Sort"
End Sub
' ============================================================
' Do_Filter with HandleError
' ============================================================
Private Sub Do_Filter(ws As Excel.Worksheet)
On Error GoTo ErrorHandler
@@ -357,16 +328,19 @@ Private Sub Do_Filter(ws As Excel.Worksheet)
Exit Sub
ErrorHandler:
MsgBox "Error: " & Err.Description, vbCritical
HandleError "Do_Filter"
End Sub
' ============================================================
' Do_Fit with HandleError
' ============================================================
Private Sub Do_Fit(ws As Excel.Worksheet)
On Error GoTo ErrorHandler
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
' 2026-05-15 adjust width function contains error column
' adjust width function contains error column
Dim startCol As String: startCol = sheetConf("ErrorCol")
Dim endCol As String: endCol = sheetConf("EndCol")
@@ -374,14 +348,16 @@ Private Sub Do_Fit(ws As Excel.Worksheet)
Exit Sub
ErrorHandler:
MsgBox "Error: " & Err.Description, vbCritical
HandleError "Do_Fit"
End Sub
' ============================================================
' RunValidationSilent
' Positive number = success (number of rows with no errors)
' 0 = no data
' -1 = has errors
' -2 = runtime error
' Returns:
' - Positive number = success (number of rows validated)
' - 0 = no data
' - -1 = has errors
' ============================================================
Public Function RunValidationSilent(ws As Worksheet) As Long
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
@@ -399,8 +375,12 @@ Public Function RunValidationSilent(ws As Worksheet) As Long
Dim r As Long
Dim hasError As Boolean: hasError = False
For r = startRow To lastDataRow
lastErrorMsg = ""
Application.Run validate, ws, r, lastDataRow
Dim errorMessage As String : errorMessage = Trim(ws.Cells(r, errorCol).Value)
If lastErrorMsg <> "" Then
Err.Raise ERR_VALIDATION_FAILED, "RunValidationSilent", lastErrorMsg
End If
Dim errorMessage As String: errorMessage = Trim(ws.Cells(r, errorCol).Value)
Dim errorCode As String: errorCode = GetCode(errorMessage)
If errorCode <> "W001" And errorCode <> "" Then
hasError = True
@@ -416,12 +396,14 @@ Public Function RunValidationSilent(ws As Worksheet) As Long
Exit Function
End Function
Public Sub HandleError(sourceProcedure As String)
Dim msg As String
' ============================================================
' Error Handlers
' ============================================================
Select Case Err.Number
Case ERR_CACHE_EMPTY
msg = Err.Description
MsgBox msg, vbExclamation
End Select
' Main error handler - centralized error processing
Public Sub HandleError(Optional ByVal sourceProcedure As String = "")
Dim shortCode As String: shortCode = Right("0000" & CStr(Err.Number - vbObjectError), 4)
MsgBox "[ERROR] " & shortCode & " : " & Err.Description, vbExclamation
End Sub
+29 -3
View File
@@ -2,9 +2,35 @@ Attribute VB_Name = "Common_Constants"
Option Explicit
' ============================================================
' Module Name: Common_Constants
' Module Desc: Common_Constants
' Module Methods:
' Module Desc: Common Error Constants
' Module Error Codes:
' - Cache errors (1001-1003)
' - File/CSV errors (5001-5009)
' - Config errors (1004-1006)
' - Validation errors (2001+)
' ============================================================
' --- Cache errors ---
Public Const ERR_CACHE_NOT_FOUND As Long = vbObjectError + 1001
Public Const ERR_CACHE_EMPTY As Long = vbObjectError + 1002
Public Const ERR_VALIDATION_FAILED As Long = vbObjectError + 1003
Public Const ERR_VALIDATION_FAILED As Long = vbObjectError + 1003
' --- File/CSV errors ---
Public Const ERR_FILE_INVALID_ARRAY As Long = vbObjectError + 5001
Public Const ERR_FILE_NOT_2D As Long = vbObjectError + 5002
Public Const ERR_FILE_NOT_FOUND As Long = vbObjectError + 5003
Public Const ERR_FILE_EMPTY As Long = vbObjectError + 5004
Public Const ERR_FILE_NO_DATA As Long = vbObjectError + 5005
Public Const ERR_FILE_COLUMN_MISMATCH As Long = vbObjectError + 5006
Public Const ERR_FILE_INVALID_PARAM As Long = vbObjectError + 5007
Public Const ERR_FILE_WRITE_FAILED As Long = vbObjectError + 5008
Public Const ERR_FILE_INVALID_DATA As Long = vbObjectError + 5009
' --- Config/Sheet errors ---
Public Const ERR_CONFIG_NOT_FOUND As Long = vbObjectError + 1004
Public Const ERR_CONFIG_INVALID As Long = vbObjectError + 1005
Public Const ERR_CONFIG_EMPTY_PARAM As Long = vbObjectError + 1006
Public Const ERR_SHEET_MISSING As Long = vbObjectError + 1007
' --- Validation errors ---
Public Const ERR_VALIDATION As Long = vbObjectError + 2001
+12 -15
View File
@@ -36,15 +36,13 @@ Sub WriteCSVFromArray( _
)
' === Input validation ===
If Not IsArray(data) Then
Err.Raise 513, , "Input 'data' must be an array."
Err.Raise ERR_FILE_INVALID_ARRAY, "WriteCSVFromArray", "Input 'data' must be an array."
End If
Dim numDims As Long
On Error Resume Next
numDims = ArrayDimensions(data)
On Error GoTo 0
' === Check if 2D array ===
Dim numDims As Long: numDims = ArrayDimensions(data)
If numDims <> 2 Then
Err.Raise 514, , "Input array must be 2-dimensional."
Err.Raise ERR_FILE_NOT_2D, "WriteCSVFromArray", "Input array must be 2-dimensional."
End If
Dim rows As Long, cols As Long
@@ -110,13 +108,12 @@ End Sub
' Helper function: safely convert any Variant to a string
Private Function SafeToString(ByVal v As Variant) As String
On Error Resume Next
If IsNull(v) Or IsEmpty(v) Then
SafeToString = ""
Else
SafeToString = CStr(v)
Exit Function
End If
On Error GoTo 0
SafeToString = CStr(v)
End Function
' Helper function: get the number of dimensions of an array (1, 2, ...)
@@ -188,11 +185,11 @@ Function ReadCSVAs2DArrayStrict( _
' === validate expectedColumnCount ===
If expectedColumnCount <= 0 Then
Err.Raise 5001, , "expectedColumnCount must be >= 1."
Err.Raise ERR_FILE_INVALID_PARAM, "ReadCSVAs2DArrayStrict", "expectedColumnCount must be >= 1."
End If
If Dir(filePath) = "" Then
Err.Raise 5002, , "File not found: " & filePath
Err.Raise ERR_FILE_NOT_FOUND, "ReadCSVAs2DArrayStrict", "File not found: " & filePath
End If
' === read csv file ===
@@ -218,12 +215,12 @@ Function ReadCSVAs2DArrayStrict( _
' === validate empty ===
If lines.Count = 0 Then
Err.Raise 5003, , "CSV file is empty."
Err.Raise ERR_FILE_EMPTY, "ReadCSVAs2DArrayStrict", "CSV file is empty."
End If
If lines.Count = 1 Then
If hasHeader Then
Err.Raise 5005, , "CSV file data is empty."
Err.Raise ERR_FILE_NO_DATA, "ReadCSVAs2DArrayStrict", "CSV file data is empty."
End If
End If
@@ -236,7 +233,7 @@ Function ReadCSVAs2DArrayStrict( _
actualCols = UBound(rowArr) - LBound(rowArr) + 1
If actualCols <> expectedColumnCount Then
Err.Raise 5004, , "Row " & i & ": Expected " & expectedColumnCount & " columns, got " & actualCols & "."
Err.Raise ERR_FILE_COLUMN_MISMATCH, "ReadCSVAs2DArrayStrict", "Row " & i & ": Expected " & expectedColumnCount & " columns, got " & actualCols & "."
End If
Next i
+20 -13
View File
@@ -42,7 +42,7 @@ Function GetCSVHeader(ByVal ws As Worksheet) As Variant
Exit Function
ErrorHandler:
Err.Raise 1005, "GetCSVHeader", "Invalid column letter in HeaderColumns: '" & colLetters(i) & "'"
Err.Raise ERR_CONFIG_INVALID, "GetCSVHeader", "Invalid column letter in HeaderColumns: '" & colLetters(i) & "'"
End Function
'
@@ -78,7 +78,7 @@ Function Contains(ByVal arr As Variant, ByVal value As String) As Boolean
Contains = False
End Function
' @return dict : key = keyColvalue = Array
' @return dict : key = keyCol, value = Array
' @param sheetName
' @param keyCol
' @param valueCols Array(4,5,6)
@@ -87,19 +87,22 @@ Function LoadLookup(ByVal sheetName As String, ByVal cacheName As String) As Obj
On Error GoTo ErrHandler
' --- validate ---
If Trim(sheetName) = "" Then Err.Raise 0001, "LoadLookup", "Sheet name cannot be empty."
If Trim(sheetName) = "" Then Err.Raise ERR_CONFIG_EMPTY_PARAM, "LoadLookup", "Sheet name cannot be empty."
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
If Not sheetConfDict.Exists(sheetName) Then
Err.Raise 1004, "LoadLookup", "Sheet not configured: " & sheetName
Err.Raise ERR_CONFIG_NOT_FOUND, "LoadLookup", "Sheet not configured: " & sheetName
End If
' --- obtain worksheet ---
Dim ws As Worksheet
On Error Resume Next
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(sheetName)
If ws Is Nothing Then Err.Raise 0003, "LoadLookup", "Worksheet named '" & sheetName & "' not found."
Set ws = ThisWorkbook.Worksheets(sheetName)
On Error GoTo ErrHandler
If ws Is Nothing Then
Err.Raise ERR_SHEET_MISSING, "LoadLookup", "Worksheet '" & sheetName & "' not found."
End If
Dim sheetConf As Object: Set sheetConf = sheetConfDict(cacheName)
Dim startRow As Long: startRow = sheetConf("StartRow")
Dim keyCol As Long: keyCol = sheetConf("KeyCol")
@@ -119,16 +122,20 @@ Function LoadLookup(ByVal sheetName As String, ByVal cacheName As String) As Obj
End If
Dim nValCols As Long: nValCols = UBound(valueCols) - LBound(valueCols) + 1
If nValCols = 0 Then Err.Raise 0002, "LoadLookup", "Value columns parameter is invalid."
If nValCols = 0 Then Err.Raise ERR_CONFIG_EMPTY_PARAM, "LoadLookup", "Value columns parameter is invalid."
' --- prepare col ---
Dim minCol As Long: minCol = keyCol
Dim maxCol As Long: maxCol = keyCol
Dim i As Long
For i = LBound(valueCols) To UBound(valueCols)
If Not IsNumeric(valueCols(i)) Then Exit Function
If Not IsNumeric(valueCols(i)) Then
Err.Raise ERR_CONFIG_INVALID, "LoadLookup", "Value column is not numeric at index " & i
End If
Dim colNum As Long: colNum = CLng(valueCols(i))
If colNum < 1 Then Exit Function
If colNum < 1 Then
Err.Raise ERR_CONFIG_INVALID, "LoadLookup", "Value column must be >= 1, got " & colNum
End If
If colNum < minCol Then minCol = colNum
If colNum > maxCol Then maxCol = colNum
Next i
@@ -203,12 +210,12 @@ Function GetLastDataRowInRange(ws As Worksheet) As Long
GetLastDataRowInRange = maxRow
Else
Err.Raise 1004, "GetLastDataRowInRange", "Sheet not configured: " & ws.CodeName
Err.Raise ERR_CONFIG_NOT_FOUND, "GetLastDataRowInRange", "Sheet not configured: " & ws.CodeName
End If
Exit Function
InvalidColumn:
Err.Raise 1005, "GetLastDataRowInRange", "Invalid column letter for sheet: " & ws.CodeName
Err.Raise ERR_CONFIG_INVALID, "GetLastDataRowInRange", "Invalid column letter for sheet: " & ws.CodeName
End Function
Function ClearDataRow(ByVal ws As Worksheet, ByVal startCol As Long, ByVal endCol As Long, ByVal rowRow As Long, Optional ByVal errorCol As Long = 2)
@@ -225,7 +232,7 @@ Sub ClearDataRows(ByVal ws As Worksheet)
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
'
If Not sheetConfDict.Exists(ws.CodeName) Then
Err.Raise 1004, "ClearDataRows", "Sheet not configured: " & ws.CodeName
Err.Raise ERR_CONFIG_NOT_FOUND, "ClearDataRows", "Sheet not configured: " & ws.CodeName
End If
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
+31 -36
View File
@@ -29,7 +29,7 @@ Public Function GetCache(ByVal cacheName As String) As Object
Dim cache As Object
Set cache = GlobalCache(cacheName)
If cache.Count = 0 Then
Err.Raise 1001, "GetCache", "No cached data found for '" & cacheName & "'. Please load the cache first."
Err.Raise ERR_CACHE_NOT_FOUND, "GetCache", "No cached data found for '" & cacheName & "'. Please load the cache first."
End If
Set GetCache = cache
@@ -38,8 +38,6 @@ End Function
' before RefreshCache, should validate
Public Sub RefreshCache(ByVal cacheName As String)
On Error GoTo RefreshError
If GlobalCache Is Nothing Then InitCacheManager
If Not GlobalCache.Exists(cacheName) Then
Set GlobalCache(cacheName) = CreateObject("Scripting.Dictionary")
@@ -56,24 +54,19 @@ Public Sub RefreshCache(ByVal cacheName As String)
Set loadedData = LookupO1Cache()
ElseIf Contains(sheetConfDict("Enum"), cacheName) Then
Set loadedData = LoadLookup("Enum", cacheName)
Else
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] } }
' Structure: { Transport type [D]: { Station from [F]: [Station to G] } }
Private Function LookupM1KukanCache()
Dim resultCache As Object
Dim resultCache As Object
Set resultCache = CreateObject("Scripting.Dictionary")
On Error GoTo ErrHandler
@@ -82,17 +75,13 @@ Private Function LookupM1KukanCache()
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
' ws exists, continue
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
If lastRow < startRow Then
Set LookupM1KukanCache = resultCache
Exit Function
End If
@@ -104,13 +93,13 @@ Private Function LookupM1KukanCache()
If dValue = "" Or fValue = "" Then GoTo NextRow2
' Outer level: D column (交通機関区分)
' D column (transport type)
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
' F column (station from) -> array of G values
Set innerDict = resultCache(dValue)
If Not innerDict.Exists(fValue) Then
Dim arr As Object: Set arr = CreateObject("Scripting.Dictionary")
@@ -129,15 +118,19 @@ NextRow2:
Exit Function
ErrHandler:
Err.Raise Err.Number, Err.Source, Err.Description
If Err.Number = 9 Then ' Subscript out of range (sheet not found)
Err.Raise ERR_SHEET_MISSING, "LookupM1KukanCache", "Sheet 'M1' not found."
Else
Err.Raise ERR_CACHE_NOT_FOUND, "LookupM1KukanCache", "Failed to load M1Kukan cache: " & Err.Description
End If
End Function
' ============================================================
' M2 Cache - Nested Dictionary
' Structure: { 区間コード[C]: { 券種[I]: { コード[J]: K } } }
' Structure: { Section code [C]: { Ticket type [I]: { Code [J]: K } } }
' ============================================================
Private Function LookupM2Cache() As Object
Dim resultCache As Object
Dim resultCache As Object
Set resultCache = CreateObject("Scripting.Dictionary")
On Error GoTo ErrHandler
@@ -146,11 +139,7 @@ Private Function LookupM2Cache() As Object
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
' ws exists, continue
Dim sheetConf As Object: Set sheetConf = sheetConfDict("M2")
Dim startRow As Long: startRow = sheetConf("StartRow")
@@ -195,25 +184,27 @@ NextRow:
Exit Function
ErrHandler:
Err.Raise Err.Number, Err.Source, Err.Description
If Err.Number = 9 Then
Err.Raise ERR_SHEET_MISSING, "LookupM2Cache", "Sheet 'M2' not found."
Else
Err.Raise ERR_CACHE_NOT_FOUND, "LookupM2Cache", "Failed to load M2 cache: " & Err.Description
End If
End Function
' ============================================================
' O1 Cache
' ============================================================
Private Function LookupO1Cache() As Object
Dim resultCache 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("O1")
On Error GoTo ErrHandler
If ws Is Nothing Then
Set LookupO1Cache = resultCache
Exit Function
End If
' ws exists, continue
Dim sheetConf As Object: Set sheetConf = sheetConfDict("O1")
Dim startRow As Long: startRow = sheetConf("StartRow")
@@ -261,7 +252,11 @@ NextO1:
Exit Function
ErrHandler:
Err.Raise Err.Number, Err.Source, Err.Description
If Err.Number = 9 Then
Err.Raise ERR_SHEET_MISSING, "LookupO1Cache", "Sheet 'O1' not found."
Else
Err.Raise ERR_CACHE_NOT_FOUND, "LookupO1Cache", "Failed to load O1 cache: " & Err.Description
End If
End Function
Private Sub RefreshSheetDict()