updsv7/vba
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Compare commits

base: updsv7:553148202ce59aaf9d5e8bcd9714b8ade937ac72
Branches Tags
updsv7:main
...
compare: updsv7:6af0ff404cd5c6923a75491e8651eb45983217fb
Branches Tags
updsv7:main

8 Commits
553148202c ... 6af0ff404c

Author SHA1 Message Date
guanxiangwei
6af0ff404c 20260515指摘対応11 2026-05-22 15:39:59 +09:00
guanxiangwei
81a8060448 20260515指摘対応10 2026-05-22 12:01:40 +09:00
guanxiangwei
56ca7ed8c5 20260515指摘対応9 2026-05-21 16:40:02 +09:00
guanxiangwei
0a633d711c 20260515指摘対応8 2026-05-21 16:02:08 +09:00
guanxiangwei
bee1cd9810 20260515指摘対応7 2026-05-21 09:57:18 +09:00
guanxiangwei
5b4ffe87aa 20260515指摘対応6 2026-05-20 18:46:15 +09:00
guanxiangwei
b25db7d99c 20260515指摘対応5 2026-05-20 14:33:18 +09:00
guanxiangwei
b359ae916b 20260515指摘対応4 2026-05-18 12:24:18 +09:00
19 changed files with 1267 additions and 683 deletions
Expand all files Collapse all files

317
src/sh/tuk/module/Common_Button.bas
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
@@ -31,63 +44,81 @@ Sub Fit_Button()
End Sub
Sub RefreshCache_Button()
On Error GoTo ErrorHandler
Dim exitMsg As String
Dim activeSheetName As String: activeSheetName = ActiveSheet.CodeName
' Determine which cache sheets to refresh based on ActiveSheet
Dim cacheSheets As Variant
If activeSheetName = "C1" Then
cacheSheets = Array("M1", "M2", "Z1", "Z2", "Z3", "Z4", "T1", "T2", "T3", "O1", "O2")
ElseIf activeSheetName = "M1" Then
cacheSheets = Array("Z1", "Z2", "Z3", "Z4", "T1", "T2", "T3", "O1", "O2")
ElseIf activeSheetName = "M2" Then
cacheSheets = Array("M1", "Z1", "Z2", "Z3", "Z4", "T1", "T2", "T3", "O1", "O2")
Else
MsgBox "This sheet does not support cache refresh.", vbExclamation
Exit Sub
End If
' Validate and refresh cache
Debug.Print "1. Validate Z1~Z4, T1~T3, O1~O2 master data"
Dim cacheSheets As Variant: cacheSheets = Array("Z1", "Z2", "Z3", "Z4", "T1", "T2", "T3", "O1", "O2")
Dim sheetName As Variant
Dim ws As Worksheet
For Each sheetName In cacheSheets
If ProcedureExists(sheetName, "Validate") Then
Dim errorCount As Long
On Error Resume Next
Set ws = ThisWorkbook.Worksheets(CStr(sheetName))
On Error GoTo 0
Dim isValid As Boolean: isValid = RunValidationSilent(ws, errorCount)
If isValid = False Then
MsgBox "Can't refresh " & sheetName & " cache. Validation error occurs."
Exit Sub
Dim result As Long: result = RunValidationSilent(ws)
If result = 0 Then
Err.Raise ERR_CACHE_EMPTY, "RefreshCache_Button", sheetName & " sheet has no data."
End If
If result < 0 Then
Err.Raise ERR_CACHE_EMPTY, "RefreshCache_Button", "Can't refresh " & sheetName & " cache. Validation error occurs."
End If
Next sheetName
' Refresh cache based on activeSheet
Dim result As Boolean: result = RefreshAllCache(activeSheetName)
If result = True Then
' Call active sheet's Refresh method
If ProcedureExists(activeSheetName, "Refresh") Then
On Error Resume Next
Set ws = ActiveSheet
On Error GoTo 0
If Not ws Is Nothing Then
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(activeSheetName)
Dim startRow As Long: startRow = sheetConf("StartRow")
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws)
Application.Run activeSheetName & ".Refresh", ws, startRow, lastDataRow
End If
Else
MsgBox "Sheet " & activeSheetName & " does not implement Refresh method.", vbExclamation
Debug.Print "2. refresh master data"
Call RefreshMasterCache()
Debug.Print "3. Determine which cache sheets to refresh based on ActiveSheet"
If activeSheetName = "C1" Then
' first is M1
Call ValidateKukanCache("M1")
Call RefreshKukanCache("M1")
Call UpdateByMaster("M1")
' second is M2
Call ValidateKukanCache("M2")
Call RefreshKukanCache("M2")
Call UpdateByMaster("M2")
ElseIf activeSheetName = "M2" Then
Call ValidateKukanCache("M1")
Call RefreshKukanCache("M1")
Call UpdateByMaster("M1")
End If
MsgBox "master data reload successfully."
Debug.Print "4. update content by other master data"
Call UpdateByMaster(activeSheetName)
Exit Sub
ErrorHandler:
HandleError "RefreshCache_Button"
End Sub
Private Sub ValidateKukanCache(ByVal sheetName As String)
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(CStr(sheetName))
Dim result As Long: result = RunValidationSilent(ws)
If result = 0 Then
Err.Raise ERR_CACHE_EMPTY, "ValidateKukanCache", sheetName & " sheet has no data."
End If
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)
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(CStr(sheetName))
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(sheetName)
Dim startRow As Long: startRow = sheetConf("StartRow")
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws)
Application.Run sheetName & ".Refresh", ws, startRow, lastDataRow
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()
@@ -101,119 +132,107 @@ 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 ===
Call ClearDataRows(ws)
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
' step1. confirm Validate Sub
If Not ProcedureExists(ws.CodeName, "Validate") Then
MsgBox "worksheet """ & ws.name & """ unimplement methods", vbExclamation
Exit Sub
Dim result As Long: result = RunValidationSilent(ws)
If result = -1 Then
Err.Raise ERR_VALIDATION_FAILED, "Do_Validation", "Validation has errors."
End If
Dim errorCount As Long
Dim isValid As Boolean: isValid = RunValidationSilent(ws, errorCount)
If result = 0 Then
Err.Raise ERR_CACHE_EMPTY, "Do_Validation", "No data to validate."
End If
If errorCount = -1 Then
MsgBox "worksheet """ & ws.Name & """ unimplement methods", vbExclamation
ElseIf errorCount = -2 Then
MsgBox "Validation error occurred.", vbCritical
ElseIf errorCount > 0 Then
MsgBox "Validation complete. Errors: " & errorCount, vbInformation
Else
If ws.CodeName <> "C1" Then
RefreshCache(ws.CodeName)
End If
MsgBox "Validation complete. Errors: 0", vbInformation
WriteCachesSheet(ws.CodeName)
End If
Do_Fit ws
MsgBox "Validation complete. Success: " & result, vbInformation
' step2. ValidateWarn for M1 sheet
If ws.CodeName = "M1" Then
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws)
Application.Run "M1.ValidateWarn", ws, lastDataRow
End If
GoTo FinallyExit
Exit Sub
ErrorHandler:
MsgBox "Error: " & Err.Description, vbCritical
Exit Sub
HandleError "Do_Validation"
GoTo FinallyExit
FinallyExit:
Do_Fit ws
ClearFormatsBelowLastDataRow ws
End Sub
'
' ============================================================
' CSV Export with HandleError
' ============================================================
Private Sub DO_CSV_Export(ws As Excel.Worksheet)
On Error GoTo ExportError
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws)
Dim startRow As Long: startRow = sheetConf("StartRow")
If lastDataRow < startRow Then
MsgBox "No data rows to output.", vbExclamation
Exit Sub
End If
On Error GoTo ErrorHandler
' === Step 1: Validate all rows before export ===
' Do_Validation
Dim errorCount As Long
If Not RunValidationSilent(ws, errorCount) Then
If errorCount > 0 Then
MsgBox "Validation failed (" & errorCount & " errors). Export aborted.", vbCritical
Exit Sub
Else
MsgBox "Validation setup error. Export aborted.", vbCritical
Exit Sub
Dim result As Long: result = RunValidationSilent(ws)
If result = 0 Then
Err.Raise ERR_CACHE_EMPTY, "DO_CSV_Export", "No data rows to output."
End If
If result < 0 Then
Err.Raise ERR_VALIDATION_FAILED, "DO_CSV_Export", "Validation failed. Export aborted."
End If
' === Step 2: Select save path ===
Dim savePath As String: savePath = GetSaveCSVPath()
If savePath = "" Then Exit Sub
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
' === Step 3: Count data rows ===
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws)
Dim startRow As Long: startRow = sheetConf("StartRow")
Dim rowCount As Long: rowCount = lastDataRow - startRow + 1
' === Step 4: Count data columns ===
@@ -224,7 +243,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
@@ -245,24 +263,27 @@ Private Sub DO_CSV_Export(ws As Excel.Worksheet)
Dim colLetters As Variant: colLetters = sheetConf("HeaderColumns")
Dim r As Long
Dim colIndex 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)
colIndex = Columns(colLetters(colIdx)).Column
outputArr(dataRow, colIdx + 1) = CleanCSVField(ws.Cells(r, colIndex).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
@@ -275,8 +296,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))
@@ -287,9 +307,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
@@ -312,16 +335,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")
@@ -329,65 +355,60 @@ Private Sub Do_Fit(ws As Excel.Worksheet)
Exit Sub
ErrorHandler:
MsgBox "Error: " & Err.Description, vbCritical
HandleError "Do_Fit"
End Sub
' ============================================================
' RunValidationSilent
Public Function RunValidationSilent(ws As Worksheet, Optional ByRef errorCountOut As Long = 0) As Boolean
On Error GoTo ErrorHandler
' 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)
' check Validate method exist
If Not ProcedureExists(ws.CodeName, "Validate") Then
errorCountOut = -1
RunValidationSilent = False
Exit Function
End If
Dim validate As String: validate = ws.CodeName & ".Validate"
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws)
Dim startRow As Long: startRow = sheetConf("StartRow")
Dim errorCol As Long: errorCol = ws.Range(sheetConf("ErrorCol") & "1").Column
If lastDataRow < startRow Then
errorCountOut = 0
RunValidationSilent = True
RunValidationSilent = 0
Exit Function
End If
Dim r As Long
errorCountOut = 0
Dim hasError As Boolean: hasError = False
For r = startRow To lastDataRow
lastErrorMsg = ""
Application.Run validate, ws, r, lastDataRow
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
errorCountOut = errorCountOut + 1
hasError = True
End If
Next r
RunValidationSilent = (errorCountOut = 0)
If hasError = True Then
RunValidationSilent = -1
Exit Function
ErrorHandler:
errorCountOut = -2
RunValidationSilent = False
End Function
Public Function ProcedureExists(ByVal moduleName As String, ByVal procName As String) As Boolean
Dim VBProj As Object, VBComp As Object, CodeMod As Object
On Error Resume Next
Set VBProj = ThisWorkbook.VBProject
Set VBComp = VBProj.VBComponents(moduleName)
If Not VBComp Is Nothing Then
Set CodeMod = VBComp.CodeModule
ProcedureExists = (CodeMod.ProcStartLine(procName, 0) > 0)
End If
If Err.Number <> 0 Then ProcedureExists = False
On Error GoTo 0
RunValidationSilent = lastDataRow - startRow + 1
Exit Function
End Function
' ============================================================
' Error Handlers
' ============================================================
' 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

36
src/sh/tuk/module/Common_Constants.bas Normal file
View File

@@ -0,0 +1,36 @@
Attribute VB_Name = "Common_Constants"
Option Explicit
' ============================================================
' Module Name: Common_Constants
' 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
' --- 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

27
src/sh/tuk/module/Common_File_Utils.bas
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

110
src/sh/tuk/module/Common_Functions.bas
View File

@@ -42,10 +42,10 @@ 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
'
' Clean CSV field: add quote prefix for formula-like values
Function CleanCSVField(ByVal inputStr As String) As String
Dim s As String
s = Trim(inputStr)
@@ -62,10 +62,12 @@ Function CleanCSVField(ByVal inputStr As String) As String
CleanCSVField = s
End Function
' Get last data row in specified column
Function GetLastDataRow(ByVal ws As Worksheet, ByVal columnNum As Long) As Long
GetLastDataRow = ws.Cells(ws.Rows.Count, columnNum).End(xlUp).Row
End Function
' Check if array contains value
Function Contains(ByVal arr As Variant, ByVal value As String) As Boolean
Dim i As Long
For i = 0 To UBound(arr)
@@ -78,7 +80,7 @@ Function Contains(ByVal arr As Variant, ByVal value As String) As Boolean
Contains = False
End Function
' @return dict : key = keyCol，value = Array
' @return dict : key = keyCol, value = Array
' @param sheetName
' @param keyCol
' @param valueCols Array(4,5,6)
@@ -87,18 +89,21 @@ 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")
@@ -119,16 +124,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
@@ -177,7 +186,7 @@ ErrHandler:
Err.Raise Err.Number, Err.Source, Err.Description
End Function
' obtain
' Get last data row in specified column
Function GetLastDataRowInRange(ws As Worksheet) As Long
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
@@ -203,14 +212,15 @@ 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
'Clear single row data and format
Function ClearDataRow(ByVal ws As Worksheet, ByVal startCol As Long, ByVal endCol As Long, ByVal rowRow As Long, Optional ByVal errorCol As Long = 2)
If rowRow >= 7 Then
Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowRow, startCol), ws.Cells(rowRow, endCol))
@@ -220,12 +230,13 @@ Function ClearDataRow(ByVal ws As Worksheet, ByVal startCol As Long, ByVal endCo
End If
End Function
'Clear all data rows from startRow to lastDataRow
Sub ClearDataRows(ByVal ws As Worksheet)
'
' Clear data and format from startRow to lastDataRow
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)
@@ -234,10 +245,9 @@ Sub ClearDataRows(ByVal ws As Worksheet)
Dim startCol As String: startCol = sheetConf("StartCol")
Dim endCol As String: endCol = sheetConf("EndCol")
Dim errorCol As String: errorCol = sheetConf("ErrorCol")
'
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws)
'
Application.EnableEvents = False
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws)
If lastDataRow >= startRow Then
Dim clearRange As Range
Set clearRange = ws.Range(ws.Cells(startRow, ws.Range(startCol & "1").Column), ws.Cells(lastDataRow, ws.Range(endCol & "1").Column))
@@ -251,9 +261,52 @@ Sub ClearDataRows(ByVal ws As Worksheet)
clearErrorRange.Interior.Color = vbWhite
End If
End If
' Clear formats below lastDataRow (including dropdowns)
Application.EnableEvents = True
Call ClearFormatsBelowLastDataRow(ws)
End Sub
' Format: code:value (no space around colon)
'Clear formats below lastDataRow
Sub ClearFormatsBelowLastDataRow(ws As Worksheet)
On Error GoTo ErrorHandler
Dim lastRow As Long: lastRow = GetLastDataRowInRange(ws)
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
Dim startCol As Long, endCol As Long
startCol = ws.Range(sheetConf("ErrorCol") & "1").Column
endCol = ws.Range(sheetConf("EndCol") & "1").Column
If lastRow >= ws.Rows.Count Then Exit Sub
Dim clearRange As Range
Set clearRange = ws.Range( _
ws.Cells(lastRow + 1, startCol), _
ws.Cells(ws.Rows.Count, endCol) _
)
Application.EnableEvents = False
clearRange.ClearContents
clearRange.Interior.Color = vbWhite
clearRange.Validation.Delete
Application.EnableEvents = True
ErrorHandler:
Application.EnableEvents = True
End Sub
' Check if text starts with prefix
Function StartsWith(text As String, prefix As String) As Boolean
If Len(text) < Len(prefix) Then
StartsWith = False
Else
StartsWith = (Left(text, Len(prefix)) = prefix)
End If
End Function
' Make select format: code:value
Function MakeSelect(ByVal code As String, ByVal value As String) As String
MakeSelect = Trim(code) & ":" & Trim(value)
End Function
@@ -309,18 +362,18 @@ Public Function FormatDateInput(ByVal inputStr As String) As String
End If
End Function
'Check header edit protection
Function CheckHeaderEdit(ByVal ws As Worksheet, ByVal Target As Range) As Boolean
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
Dim headerRow As Long: headerRow = sheetConf("HeaderRow")
Dim filterRow As Long: filterRow = sheetConf("FilterRow")
' Check header row (headerRow) cannot be edited
' Check rows 1 to filterRow cannot be edited
Dim r As Long
For r = Target.Row To Target.Row + Target.Rows.Count - 1
If r = headerRow Or r = filterRow Then
If r >= 1 And r <= filterRow Then
Application.EnableEvents = False
MsgBox "Header or type definition row cannot be edited.", vbExclamation
MsgBox "Cannot edit rows 1 to " & filterRow & ".", vbExclamation
Application.Undo
Application.EnableEvents = True
@@ -348,6 +401,7 @@ Function CheckHeaderEdit(ByVal ws As Worksheet, ByVal Target As Range) As Boolea
CheckHeaderEdit = False
End Function
'Get error message by code
Function GetErrorMsg(ByVal errorCode As String, Optional ByVal param0 As String = "", Optional ByVal param1 As String = "") As String
Dim errorList As Object: Set errorList = GetCache("errorList")
Dim errorMessage As String
@@ -359,10 +413,12 @@ Function GetErrorMsg(ByVal errorCode As String, Optional ByVal param0 As String
GetErrorMsg = errorMessage
End Function
'Convert column number to letter
Function ColLetter(colNum As Long) As String
ColLetter = Split(Cells(1, colNum).Address, "$")(1)
End Function
'Check required field is not empty
Function CheckRequired(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal errorCol As String) As Boolean
Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
If checkValue = "" Then
@@ -375,6 +431,7 @@ Function CheckRequired(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum
CheckRequired = True
End Function
'Check character length
Function CheckChar(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal charLength As Long, ByVal errorCol As String)
Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
If Len(checkValue) <> charLength Then
@@ -387,6 +444,7 @@ Function CheckChar(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As
CheckChar = True
End Function
'Check alphanumeric characters
Function CheckAlphanumeric(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal charLength As Long, ByVal errorCol As String)
Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
Dim letter As String: letter = ColLetter(colNum)
@@ -405,6 +463,7 @@ Function CheckAlphanumeric(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal co
CheckAlphanumeric = True
End Function
'Check varchar length overflow
Function CheckVarcharOver(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal varcharLength As Long, ByVal errorCol As String)
Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
If Len(checkValue) > varcharLength Then
@@ -417,6 +476,7 @@ Function CheckVarcharOver(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal col
CheckVarcharOver = True
End Function
'Check number length overflow
Function CheckNumberOver(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal numberLength As Long, ByVal errorCol As String)
Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
If Len(checkValue) > numberLength Then
@@ -429,6 +489,7 @@ Function CheckNumberOver(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colN
CheckNumberOver = True
End Function
'Check value is 0 or 1
Function Check01(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal errorCol As String)
Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
Dim letter As String: letter = ColLetter(colNum)
@@ -449,6 +510,7 @@ Function Check01(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Lo
Check01 = True
End Function
'Check value is 1 or 2
Function Check12(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal errorCol As String)
Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
Dim letter As String: letter = ColLetter(colNum)
@@ -469,6 +531,7 @@ Function Check12(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Lo
Check12 = True
End Function
'Check duplicate value in column
Function CheckDuplicate(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal errorCol As String) As Boolean
Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
Dim letter As String: letter = ColLetter(colNum)
@@ -486,6 +549,7 @@ Function CheckDuplicate(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNu
CheckDuplicate = True
End Function
'Check numeric value
Function CheckNumber(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal errorCol As String) As Boolean
Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
Dim letter As String: letter = ColLetter(colNum)

224
src/sh/tuk/module/Common_Global_Cache.bas
View File

@@ -9,7 +9,7 @@ Option Explicit
' - RefreshO1Cache
' ============================================================
Private sheetConfDict As Object
Private FormulaCache As Object
Public GlobalCache As Object
Public Sub InitCacheManager()
@@ -20,65 +20,31 @@ Public Sub InitCacheManager()
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
Dim cache As Object
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
Err.Raise ERR_CACHE_NOT_FOUND, "GetCache", "No cached data found for '" & cacheName & "'. Please load the cache first."
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 loadedData As Object
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
If cacheName = "M1KukanDCache" Then
Set loadedData = LookupM1KukanCache()
@@ -95,15 +61,10 @@ Public Sub RefreshCache(ByVal cacheName As String)
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
Set resultCache = CreateObject("Scripting.Dictionary")
@@ -114,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
Set LookupM1KukanCache = resultCache
Exit Function
End If
@@ -136,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")
@@ -161,12 +118,16 @@ 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
@@ -178,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")
@@ -227,7 +184,11 @@ 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
' ============================================================
@@ -237,15 +198,13 @@ Private Function LookupO1Cache() 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")
@@ -293,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()
@@ -456,7 +419,7 @@ Private Sub RefreshSheetDict()
sheetConf("AlwaysQuote") = True
sheetConf("FilterRow") = 6
sheetConf("KeyCol") = 3
sheetConf("ValueCols") = Array(4, 6, 8, 9, 10, 11, 12, 13)
sheetConf("ValueCols") = Array(4, 8, 9, 10, 11, 12, 13)
Set sheetConfDict("T2") = sheetConf
Debug.Print "RefreshSheetDict T2 ok."
@@ -514,7 +477,7 @@ Private Sub RefreshSheetDict()
' Enum
Set sheetConf = Nothing
sheetConfDict("Enum") = Array("tokubetuList", "kenshuList", "oufukuList", "koutaiList", "higaitouList", "errorList")
sheetConfDict("Enum") = Array("tokubetuList", "kenshuList", "renrakuList", "oufukuList", "koutaiList", "higaitouList", "errorList")
Debug.Print "RefreshSheetDict Enum ok."
' tokubetuList
@@ -533,38 +496,52 @@ Private Sub RefreshSheetDict()
Set sheetConfDict("kenshuList") = sheetConf
Debug.Print "RefreshSheetDict kenshuList ok."
' oufukuList
' renrakuList
Set sheetConf = CreateObject("Scripting.Dictionary")
sheetConf("StartRow") = 3
sheetConf("KeyCol") = 6
sheetConf("ValueCols") = Array(7)
sheetConf("ValueCols") = Array(6)
Set sheetConfDict("renrakuList") = sheetConf
Debug.Print "RefreshSheetDict renrakuList ok."
' oufukuList
Set sheetConf = CreateObject("Scripting.Dictionary")
sheetConf("StartRow") = 3
sheetConf("KeyCol") = 8
sheetConf("ValueCols") = Array(9)
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)
sheetConf("KeyCol") = 11
sheetConf("ValueCols") = Array(12)
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)
sheetConf("KeyCol") = 14
sheetConf("ValueCols") = Array(15)
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)
sheetConf("KeyCol") = 17
sheetConf("ValueCols") = Array(18)
Set sheetConfDict("errorList") = sheetConf
Debug.Print "RefreshSheetDict errorList ok."
' Caches
Set sheetConf = CreateObject("Scripting.Dictionary")
' TODO
Set sheetConfDict("Caches") = sheetConf
Debug.Print "RefreshSheetDict Caches ok."
Debug.Print "RefreshSheetDict end."
End Sub
@@ -573,32 +550,93 @@ Public Function GetSheetConfig() As Object
Set GetSheetConfig = sheetConfDict
End Function
Public Function RefreshAllCache(Optional ByVal activeSheetName As String = "") As Boolean
Public Sub RefreshMasterCache()
' Fixed cache names
Dim fixedCaches As Variant
fixedCaches = Array("Z1", "Z2", "Z3", "Z4", "T1", "T2", "T3", "O1", "O2", _
"tokubetuList", "kenshuList", "oufukuList", "koutaiList", "higaitouList", "errorList")
' Dynamic cache names based on activeSheet
Dim dynamicCaches As Variant
If activeSheetName = "C1" Then
dynamicCaches = Array("M1", "M1KukanDCache", "M2")
ElseIf activeSheetName = "M2" Then
dynamicCaches = Array("M1", "M1KukanDCache")
Else
dynamicCaches = Array()
End If
"tokubetuList", "kenshuList", "renrakuList", "oufukuList", "koutaiList", "higaitouList", "errorList")
' Refresh fixed caches
Dim cacheName As Variant
For Each cacheName In fixedCaches
Call RefreshCache(CStr(cacheName))
Call WriteCachesSheet(CStr(cacheName))
Next cacheName
End Sub
' Refresh dynamic caches
For Each cacheName In dynamicCaches
Call RefreshCache(CStr(cacheName))
Next cacheName
Public Sub RefreshKukanCache(ByVal sheetName As String)
If sheetName = "M1" Then
Call RefreshCache("M1")
Call RefreshCache("M1KukanDCache")
Call WriteCachesSheet("M1")
End If
If sheetName = "M2" Then
Call RefreshCache("M2")
Call WriteCachesSheet("M2")
End If
End Sub
RefreshAllCache = True
' Write cache data to Caches sheet for dropdown
Public Sub WriteCachesSheet(ByVal cacheName As String)
Dim wsCache As Worksheet
Set wsCache = ThisWorkbook.Sheets("Caches")
If wsCache Is Nothing Then
Set wsCache = ThisWorkbook.Sheets.Add
wsCache.Name = "Caches"
wsCache.Visible = xlVeryHidden
End If
' Map cacheName to column letter
Dim colLetter As String
Select Case cacheName
Case "Z1": colLetter = "A"
Case "Z2": colLetter = "B"
Case "Z3": colLetter = "C"
Case "Z4": colLetter = "D"
Case "T1": colLetter = "E"
Case "T2": colLetter = "F"
Case "T3": colLetter = "G"
Case "O2": colLetter = "H"
Case "M1": colLetter = "I"
Case Else: Exit Sub
End Select
Dim cache As Object: Set cache = GetCache(cacheName)
If cache Is Nothing Then Exit Sub
' Write to Caches sheet
wsCache.Columns(colLetter).ClearContents
Dim idx As Long: idx = 1
Dim key As Variant
For Each key In cache.Keys
If key <> 0 Then
Dim displayText As String: displayText = MakeSelect(key, cache(key)(0))
If displayText <> "" Then
wsCache.Cells(idx, colLetter).Value = displayText
idx = idx + 1
End If
End If
Next key
Dim lastRow As Long: lastRow = wsCache.Cells(wsCache.Rows.Count, colLetter).End(xlUp).Row
Dim formulaStr As String
If lastRow >= 1 Then
formulaStr = "=Caches!" & colLetter & "1:" & colLetter & lastRow
Else
formulaStr = "=Caches!" & colLetter & "1"
End If
' write into FormulaCache
If FormulaCache Is Nothing Then Set FormulaCache = CreateObject("Scripting.Dictionary")
FormulaCache(cacheName) = formulaStr
End Sub
Public Function GetValidationFormula(ByVal cacheName As String) As String
If FormulaCache Is Nothing Then Set FormulaCache = CreateObject("Scripting.Dictionary")
If FormulaCache.Exists(cacheName) Then
GetValidationFormula = FormulaCache(cacheName)
Else
GetValidationFormula = ""
End If
End Function

118
src/sh/tuk/module/Common_Selector.bas
View File

@@ -1,21 +1,24 @@
Attribute VB_Name = "Common_Selector"
Option Explicit
' ============================================================
' Module Name: Build_Select
' Module Desc: Commuter allowance editing sheet (no CSV import)
' Module Name: Common_Selector
' Module Desc: Build dropdown lists from cache data
' Module Methods:
' - Tukin_ValidateRow
' - FillTransportFromM1KukanD
' - FillDepartureFromM1KukanD
' - FillArrivalFromM1KukanD
' - FillKukanFromM1
' - FillKanshuFromM2
' - FillCodeFromM2
' - FillAddressFromO1
' - FillZ1Dropdown
' - BuildTransportList
' - BuildTodokeList
' - BuildOufukuList
' - BuildKoutaiList
' - BuildKetteiList
' - BuildHigaitouList
' - BuildMonthAmountKbnList
' - BuildKanshokuList
' - BuildKenshuList
' ============================================================
' Create transport (T) dropdown from Z1 cache
' ============================================================
' Event Handlers
' ============================================================
' Create Transport (T) dropdown from Z1 cache
Public Function BuildTransportList()
Dim z1Cache As Object: Set z1Cache = GetCache("Z1")
@@ -34,7 +37,7 @@ Public Function BuildTransportList()
BuildTransportList = dropdownList
End Function
' Create todoke (G) dropdown
' Create Todoke (G) dropdown
Public Function BuildTodokeList()
Dim z4Cache As Object: Set z4Cache = GetCache("Z4")
@@ -52,7 +55,7 @@ Public Function BuildTodokeList()
BuildTodokeList = dropdownList
End Function
' Create oufuku (M) dropdown
' Create Oufuku (M) dropdown
Public Function BuildOufukuList()
Dim oufukuList As Object: Set oufukuList = GetCache("oufukuList")
@@ -159,3 +162,90 @@ Public Function BuildKanshokuList()
Next key
BuildKanshokuList = dropdownList
End Function
' Create Kenshu dropdown (exclude key = 0)
Public Sub BuildKenshuDropdown(ws As Worksheet, ByVal columnLetter As String, ByVal rowNum As Long)
Dim kenshuList As Object: Set kenshuList = GetCache("kenshuList")
Dim dropdownList As String
Dim key As Variant
For Each key In kenshuList.Keys
If key <> 0 Then
Dim displayText As String
displayText = MakeSelect(key, kenshuList(key)(0))
If dropdownList = "" Then
dropdownList = displayText
Else
dropdownList = dropdownList & "," & displayText
End If
End If
Next key
With ws.Range(columnLetter & rowNum).Validation
.Delete
.Add Type:=xlValidateList, Formula1:=dropdownList
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.InputMessage = ""
End With
End Sub
' Create Tokubetu dropdown
Public Sub BuildTokubetuDropdown(ws As Worksheet, ByVal columnLetter As String, ByVal rowNum As Long)
Dim tokubetuList As Object: Set tokubetuList = GetCache("tokubetuList")
Dim dropdownList As String: dropdownList = ""
Dim key As Variant
For Each key In tokubetuList.Keys
If dropdownList = "" Then
dropdownList = key
Else
dropdownList = dropdownList & "," & key
End If
Next key
With ws.Range(columnLetter & rowNum).Validation
.Delete
.Add Type:=xlValidateList, Formula1:=dropdownList
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.InputMessage = ""
End With
End Sub
' Create Renraku dropdown
Public Sub BuildRenrakuDropdown(ws As Worksheet, ByVal columnLetter As String, ByVal rowNum As Long)
Dim renrakuList As Object: Set renrakuList = GetCache("renrakuList")
Dim dropdownList As String: dropdownList = ""
Dim key As Variant
For Each key In renrakuList.Keys
If dropdownList = "" Then
dropdownList = key
Else
dropdownList = dropdownList & "," & key
End If
Next key
With ws.Range(columnLetter & rowNum).Validation
.Delete
.Add Type:=xlValidateList, Formula1:=dropdownList
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.InputMessage = ""
End With
End Sub
' Build dropdown using Caches sheet
Public Sub BuildDropdownFromCacheNamedRange(ws As Worksheet, columnLetter As String, rowNum As Long, cacheName As String)
Dim formula As String: formula = GetValidationFormula(cacheName)
If formula = "" Then Exit Sub
With ws.Range(columnLetter & rowNum).Validation
.Delete
.Add Type:=xlValidateList, Formula1:=formula
.IgnoreBlank = True
.InCellDropdown = True
End With
End Sub

180
src/sh/tuk/sheet/C1.cls
View File

@@ -9,7 +9,7 @@
' - FillKukanFromM1
' - FillKanshuFromM2
' - FillCodeFromM2
' - CreateAddress1Dropdown
' - BuildAddress1Dropdown
' - FillZ1Dropdown
' ============================================================
' ====== (Tukin_C1) =======
@@ -102,11 +102,10 @@ Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row < 8 Then Exit Sub
Dim idx As Long
' Check if cache is loaded
Application.EnableEvents = False
On Error GoTo Finally
' === 3. rebuild dropdown list ===
Call RebuildDropdownsForTarget(Target)
Dim testCache As Object: Set testCache = GetCache("Z1")
' === Column C changes ===
If Target.Column = 3 Then
@@ -116,7 +115,12 @@ Private Sub Worksheet_Change(ByVal Target As Range)
If cshainno = "" Then
Call ClearRowData(cell.Row)
Else
Call CreateAddress1Dropdown(cell.Row, cshainno)
' rebuild dropdown list
Call BuildAddress1Dropdown(cell.Row, cshainno)
Call ReFillAddress1(cell.Row, cshainno)
Call BuildAddress2Dropdown(cell.Row, cshainno)
Call ReFillAddress2(cell.Row, cshainno)
Call RebuildDropdowns(cell.Row)
End If
Next
End If
@@ -141,7 +145,7 @@ Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 9 Then
Dim cellI As Range
For Each cellI In Target
Call CreateAddress2Dropdown(cellI.Row)
Call BuildAddress2Dropdown(cellI.Row, Trim(Me.Cells(cellI.Row, CSHAINNO_COL).Value))
Next
End If
@@ -228,27 +232,52 @@ Private Sub Worksheet_Change(ByVal Target As Range)
Next
End If
Application.EnableEvents = True
Exit Sub
Finally:
HandleError "Worksheet_Change"
Application.EnableEvents = True '
End Sub
Private Sub RebuildDropdownsForTarget(ByVal Target As Range)
If Target Is Nothing Then Exit Sub
' Prevent insert/delete row in header area
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(Me.CodeName)
Dim filterRow As Long: filterRow = sheetConf("FilterRow")
Dim cell As Range
Dim processedRows As Object
Set processedRows = CreateObject("Scripting.Dictionary")
If Target.Row < filterRow + 1 Then
Cancel = True
MsgBox "Cannot insert or delete row in header area.", vbExclamation
End If
End Sub
Private Sub Refresh(ws As Worksheet, ByVal startRow As Long, ByVal lastDataRow As Long)
Dim z1Cache As Object: Set z1Cache = GetCache("Z1")
Application.EnableEvents = False
On Error GoTo ErrorHandler
For Each cell In Target
Dim r As Long
r = cell.Row
For r = startRow To lastDataRow
Dim cshainno As String: cshainno = Trim(Me.Cells(r, CSHAINNO_COL).Value)
Call BuildAddress1Dropdown(r, cshainno)
Call ReFillAddress1(r, cshainno)
Call BuildAddress2Dropdown(r, cshainno)
Call ReFillAddress2(r, cshainno)
Call RebuildDropdowns(r)
Call ReFillFromDropdowns(r)
Next r
If Not processedRows.Exists(r) Then
processedRows(r) = True
Application.EnableEvents = True
Exit Sub
Dim colLetter As String
colLetter = Split(Me.Cells(1, cell.Column).Address(True, False), "$")(0)
ErrorHandler:
Application.EnableEvents = True
Err.Raise ERR_CACHE_NOT_FOUND, "M1.Refresh", "Failed to refresh M1: " & Err.Description
End Sub
Private Sub RebuildDropdowns(ByVal rowNum As Long)
Dim dropdowns As Variant
dropdowns = Array( _
Array("T", "BuildTransportList"), _
@@ -266,19 +295,57 @@ Private Sub RebuildDropdownsForTarget(ByVal Target As Range)
Dim i As Long
For i = LBound(dropdowns) To UBound(dropdowns)
If colLetter <> dropdowns(i)(0) Then
With Me.Cells(r, dropdowns(i)(0)).Validation
With Me.Cells(rowNum, dropdowns(i)(0)).Validation
.Delete
.Add Type:=xlValidateList, Formula1:=Application.Run(dropdowns(i)(1))
.IgnoreBlank = True
.InCellDropdown = True
End With
End If
Next i
End Sub
Private Sub ReFillFromDropdowns(ByVal rowNum As Long)
Dim dropdowns As Variant
dropdowns = Array( _
Array("T", "BuildTransportList"), _
Array("AA", "BuildTransportList"), _
Array("AH", "BuildTransportList"), _
Array("AO", "BuildTransportList"), _
Array("G", "BuildTodokeList"), _
Array("M", "BuildOufukuList"), _
Array("N", "BuildKoutaiList"), _
Array("AU", "BuildKetteiList"), _
Array("AW", "BuildHigaitouList"), _
Array("AX", "BuildMonthAmountKbnList"), _
Array("BC", "BuildKanshokuList") _
)
Dim i As Long
For i = LBound(dropdowns) To UBound(dropdowns)
Dim col As String: col = dropdowns(i)(0)
Dim funcName As String: funcName = dropdowns(i)(1)
Dim cellValue As String: cellValue = Trim(Me.Cells(rowNum, col).Value)
If cellValue = "" Then GoTo NextDropdown
Dim key As String: key = GetCode(cellValue)
If InStr(cellValue, ":") = 0 Then GoTo NextDropdown ' Skip if not key:value format
' Get dropdown list
Dim dropdownList As String: dropdownList = Application.Run(funcName)
Dim items As Variant: items = Split(dropdownList, ",")
' Check if key exists in dropdown
Dim j As Long
For j = LBound(items) To UBound(items)
Dim item As String: item = Trim(items(j))
If GetCode(item) = key Then
' Found matching key, update with full key:value
Me.Cells(rowNum, col).Value = item
Exit For
End If
NextCell:
Next cell
Next j
NextDropdown:
Next i
End Sub
' Fill kukan info from M1 cache (key: kukan code, value: 7 elements)
@@ -319,12 +386,8 @@ End Sub
' triggered by c clomun cshainno input
' when cshainno does not exist in o1, clear dropdownList and value
' when cshainno exist in o1, create dropdownList and value
Private Sub CreateAddress1Dropdown(ByVal rowNum As Long, ByVal cshainno As String)
Private Sub BuildAddress1Dropdown(ByVal rowNum As Long, ByVal cshainno As String)
Dim o1Cache As Object: Set o1Cache = GetCache("O1")
Me.Range("I" & rowNum).Validation.Delete
Me.Range("I" & rowNum).Value = ""
Me.Range("J" & rowNum).Validation.Delete
Me.Range("J" & rowNum).Value = ""
' Build dropdown list from O1 cache: get all E values for the C
Dim dropdownList As String
If o1Cache.Exists(cshainno) Then
@@ -353,14 +416,35 @@ Private Sub CreateAddress1Dropdown(ByVal rowNum As Long, ByVal cshainno As Strin
End If
End Sub
Private Sub ReFillAddress1(ByVal rowNum As Long, ByVal cshainno As String)
Dim o1Cache As Object: Set o1Cache = GetCache("O1")
If Not o1Cache.Exists(cshainno) Then
Me.Cells(rowNum, ADDRESS1_COL).Value = ""
Exit Sub
End If
Dim innerDict As Object: Set innerDict = o1Cache(cshainno)
If innerDict.Count = 1 Then
' Auto-fill if only one key exists
Dim keys As Variant: keys = innerDict.Keys
Me.Cells(rowNum, ADDRESS1_COL).Value = keys(0)
Exit Sub
End If
Dim originalValue As String: originalValue = Trim(Me.Cells(rowNum, ADDRESS1_COL).Value)
If originalValue = "" Then Exit Sub
' Clear if value not found in O1 cache keys
If Not innerDict.Exists(originalValue) Then
Me.Cells(rowNum, ADDRESS1_COL).Value = ""
End If
End Sub
' triggered by address1 select O1 cache
Private Sub CreateAddress2Dropdown(ByVal rowNum As Long)
Private Sub BuildAddress2Dropdown(ByVal rowNum As Long, ByVal cshainno As String)
' Clear address2 contents
Me.Range(ADDRESS2_COL & rowNum).Validation.Delete
Me.Range(ADDRESS2_COL & rowNum).Value = ""
' obtain cshainno, address1, o1Cache
Dim o1Cache As Object: Set o1Cache = GetCache("O1")
Dim cshainno As String: cshainno = Trim(Me.Cells(rowNum, CSHAINNO_COL).Value)
Dim address1 As String: address1 = Trim(Me.Cells(rowNum, ADDRESS1_COL).Value)
If cshainno = "" OR address1 = "" Then
Exit Sub
@@ -400,6 +484,35 @@ Private Sub CreateAddress2Dropdown(ByVal rowNum As Long)
End If
End Sub
Private Sub ReFillAddress2(ByVal rowNum As Long, ByVal cshainno As String)
Dim address1 As String: address1 = Trim(Me.Cells(rowNum, ADDRESS1_COL).Value)
If address1 = "" Then
Me.Cells(rowNum, ADDRESS2_COL).Value = ""
Exit Sub
End If
Dim o1Cache As Object: Set o1Cache = GetCache("O1")
If Not o1Cache.Exists(cshainno) Then
Me.Cells(rowNum, ADDRESS2_COL).Value = ""
Exit Sub
End If
Dim innerDict As Object: Set innerDict = o1Cache(cshainno)
If Not innerDict.Exists(address1) Then
Me.Cells(rowNum, ADDRESS2_COL).Value = ""
Exit Sub
End If
Dim addr2Dict As Object: Set addr2Dict = innerDict(address1)
If addr2Dict.Count = 1 Then
Dim keys As Variant: keys = addr2Dict.Keys
Me.Cells(rowNum, ADDRESS2_COL).Value = keys(0)
Exit Sub
End If
Me.Cells(rowNum, ADDRESS2_COL).Value = ""
End Sub
' Create station from dropdown from M1_KukanD cache
Private Sub CreateFromStationDropdown(ByVal rowNum As Long, ByVal transportCol As Long, ByVal stationCol As Long)
Dim m1KukanDCache As Object: Set m1KukanDCache = GetCache("M1KukanDCache")
@@ -590,6 +703,7 @@ End Sub
' Validation logic
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
On Error GoTo ErrHandler
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
@@ -843,4 +957,8 @@ Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
End If
Me.Cells(rowNum, errorCol).ClearContents
Exit Sub
ErrHandler:
lastErrorMsg = Err.Description
End Sub

145
src/sh/tuk/sheet/M1.cls
View File

@@ -7,38 +7,13 @@
' - Validate
' ============================================================
' Create dropdown for L column
Private Sub CreateEnumDropdown(ByVal rowNum As Long)
Dim tokubetuList As Object: Set tokubetuList = GetCache("tokubetuList")
' Build dropdown list from tokubetuList
Dim dropdownList As String
dropdownList = ""
Dim key As Variant
For Each key In tokubetuList.Keys
If dropdownList = "" Then
dropdownList = key
Else
dropdownList = dropdownList & "," & key
End If
Next key
With Me.Range("L" & rowNum).Validation
.Delete
.Add Type:=xlValidateList, Formula1:=dropdownList
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.InputMessage = ""
End With
End Sub
'
Private Sub Worksheet_Change(ByVal Target As Range)
Dim HasHeaderEdit As Boolean: HasHeaderEdit = CheckHeaderEdit(Me, Target)
If HasHeaderEdit = True Then Exit Sub
' Multi-cell selection not processed
If Target.Count > 1 Then Exit Sub
' === Column C changes: Create L column dropdown ===
If Target.Column = 3 And Target.Row >= 7 Then
Dim cell As Range
@@ -47,7 +22,8 @@ Private Sub Worksheet_Change(ByVal Target As Range)
Me.Cells(cell.Row, 12).Validation.Delete
Call ClearDataRow(Me, START_COL + 1, END_COL, cell.Row, ERROR_COL)
Else
Call CreateEnumDropdown(cell.Row)
Call BuildTokubetuDropdown(Me, "L", cell.Row)
Call BuildRenrakuDropdown(Me, "K", cell.Row)
End If
Next
End If
@@ -73,7 +49,20 @@ Private Sub Worksheet_Change(ByVal Target As Range)
End If
End Sub
' Prevent insert/delete row in header area
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(Me.CodeName)
Dim filterRow As Long: filterRow = sheetConf("FilterRow")
If Target.Row < filterRow + 1 Then
Cancel = True
MsgBox "Cannot insert or delete row in header area.", vbExclamation
End If
End Sub
Private Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
On Error GoTo ErrHandler
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
@@ -85,11 +74,13 @@ Private Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol))
clearRange.Interior.Color = vbWhite
Dim errorCell As Range: Set errorCell = ws.Cells(rowNum, errorCol)
' Check column required
Dim colLetter As Variant
For Each colLetter In Array("C", "D", "E", "F", "G", "I", "L")
If Trim(ws.Range(colLetter & rowNum).Value) = "" Then
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E002", colLetter & rowNum)
errorCell.Value = GetErrorMsg("E002", colLetter & rowNum)
ws.Range(colLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
@@ -99,7 +90,7 @@ Private Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
For Each colLetter In Array("H", "I", "J", "N")
Dim val As String: val = Trim(ws.Range(colLetter & rowNum).Value)
If val <> "" And Not IsNumeric(val) Then
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E011", colLetter & rowNum)
errorCell.Value = GetErrorMsg("E011", colLetter & rowNum)
ws.Range(colLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
@@ -111,7 +102,7 @@ Private Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
Set foundCell = ws.Range("C7:C" & lastDataRow).Find(What:=cValue, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not foundCell Is Nothing Then
If foundCell.Row <> rowNum Then
ws.Cells(rowNum, errorCol).Value = "C column value is duplicated"
errorCell.Value = "C column value is duplicated"
ws.Range("C" & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
@@ -124,14 +115,14 @@ Private Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
Dim eValue As String: eValue = Trim(ws.Range("E" & rowNum).Value)
If Not z1Cache.Exists(dValue) Then
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E004", "D" & rowNum)
errorCell.Value = GetErrorMsg("E004", "D" & rowNum)
ws.Range("D" & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
Else
Dim valueArray As Variant
valueArray = z1Cache(dValue)
If Not IsArray(valueArray) Or UBound(valueArray) < 0 Then
ws.Cells(rowNum, errorCol).Value = "Invalid reference data for D column."
errorCell.Value = "Invalid reference data for D column."
Exit Sub
End If
@@ -139,7 +130,7 @@ Private Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
expectedEValue = Trim(CStr(valueArray(0)))
If eValue <> expectedEValue Then
ws.Cells(rowNum, errorCol).Value = "E column does not match reference data."
errorCell.Value = "E column does not match reference data."
ws.Range("E" & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
@@ -149,30 +140,27 @@ Private Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
Dim tokubetuList As Object: Set tokubetuList = GetCache("tokubetuList")
Dim lValue As String: lValue = Trim(ws.Range("L" & rowNum).Value)
If Not tokubetuList.Exists(lValue) Then
ws.Cells(rowNum, errorCol).Value = "L column does not exist."
errorCell.Value = "L column does not exist."
ws.Range("L" & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
' Check if M2 uses this M1 kukan code
Dim m2Cache As Object: Set m2Cache = GetCache("M2")
If Not m2Cache.Exists(cValue) Then
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("W001", cValue)
ws.Range("C" & rowNum).Interior.Color = RGB(255, 128, 0)
Exit Sub
End If
' Validation passed - clear error
ws.Cells(rowNum, errorCol).ClearContents
If Not StartsWith(errorCell.Value, "W") Then
errorCell.ClearContents
End If
Exit Sub
ErrHandler:
lastErrorMsg = Err.Description
End Sub
' obtain z1 master data, and update column E
Private Sub Refresh(ws As Worksheet, ByVal startRow As Long, ByVal lastDataRow As Long)
Dim z1Cache As Object: Set z1Cache = GetCache("Z1")
If z1Cache Is Nothing Then Exit Sub
Application.EnableEvents = False
On Error GoTo Finally
On Error GoTo ErrorHandler
Dim r As Long
For r = startRow To lastDataRow
@@ -181,8 +169,69 @@ Private Sub Refresh(ws As Worksheet, ByVal startRow As Long, ByVal lastDataRow A
Dim valsD As Variant: valsD = z1Cache(dVal)
ws.Cells(r, 5).Value = valsD(0) ' Column E
End If
Call BuildTokubetuDropdown(ws, "L", r)
Call BuildRenrakuDropdown(ws, "K", r)
Next r
Finally:
Application.EnableEvents = True
Exit Sub
ErrorHandler:
Application.EnableEvents = True
Err.Raise ERR_CACHE_NOT_FOUND, "M1.Refresh", "Failed to refresh M1: " & Err.Description
End Sub
Private Sub ValidateWarn(ws As Worksheet, ByVal lastDataRow As Long)
On Error GoTo ErrorHandler
Dim exitMsg As String
' Get M2 sheet kukan code list directly
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim m2SheetConf As Object: Set m2SheetConf = sheetConfDict("M2")
Dim m2StartRow As Long: m2StartRow = m2SheetConf("StartRow")
Dim wsM2 As Worksheet: Set wsM2 = ThisWorkbook.Worksheets("M2")
Dim lastRowM2 As Long: lastRowM2 = GetLastDataRowInRange(wsM2)
If lastRowM2 < m2StartRow Then
exitMsg = "M2 sheet has no data"
GoTo ErrorHandler
End If
' Build kukan code list from M2 sheet
Dim kukanList As Object: Set kukanList = CreateObject("Scripting.Dictionary")
Dim r As Long
For r = m2StartRow To lastRowM2
Dim kukanCode As String: kukanCode = Trim(wsM2.Cells(r, 3).Value)
If kukanCode <> "" And Not kukanList.Exists(kukanCode) Then
kukanList.Add kukanCode, True
End If
Next r
Dim sheetConf As Object: Set sheetConf = sheetConfDict("M1")
Dim startRow As Long: startRow = sheetConf("StartRow")
Dim errorCol As String: errorCol = sheetConf("ErrorCol")
' Check all rows in M1 sheet
If lastDataRow < startRow Then
exitMsg = "M1 sheet has no data"
GoTo ErrorHandler
End If
Dim rowNum As Long
For rowNum = startRow To lastDataRow
Dim cValue As String: cValue = Trim(ws.Range("C" & rowNum).Value)
If Not kukanList.Exists(cValue) Then
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("W001", cValue)
ws.Range("C" & rowNum).Interior.Color = RGB(255, 128, 0)
End If
NextRow:
Next rowNum
Exit Sub
ErrorHandler:
If exitMsg <> "" Then
MsgBox "ValidateWarn: " & exitMsg, vbExclamation
Else
MsgBox "ValidateWarn: " & Err.Description, vbExclamation
End If
End Sub

509
src/sh/tuk/sheet/M2.cls
View File

@@ -37,6 +37,7 @@ Private Sub Worksheet_Change(ByVal Target As Range)
GoTo Finally
Else
Call FillFromM1(Me, cell.Row)
Call BuildKenshuDropdown(Me, "I", cell.Row)
End If
Next
End If
@@ -45,11 +46,17 @@ Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 9 Then
Dim cellI As Range
For Each cellI In Target
' Store key only (e.g., "1") in I column
Dim kenshuKey As String: kenshuKey = GetCode(cellI.Value)
If kenshuKey <> "" Then
cellI.Value = kenshuKey
End If
' clear
Me.Range(Me.Cells(cellI.Row, 10), Me.Cells(cellI.Row, 18)).ClearContents
Me.Cells(cellI.Row, 11).Validation.Delete
Me.Range(Me.Cells(cellI.Row, 10), Me.Cells(cellI.Row, 18)).Interior.Color = vbWhite
Me.Cells(cellI.Row, 10).Validation.Delete
Call CreateJDropdown(cellI.Row)
Call ChangeBackColor(cellI.Row)
Next
End If
@@ -61,7 +68,7 @@ Private Sub Worksheet_Change(ByVal Target As Range)
Next
End If
Dim kenshuKbn As String: kenshuKbn = Trim(Me.Range("I" & Target.Row).value)
Dim kenshuKbn As String: kenshuKbn = Trim(Me.Range("I" & Target.Row).Value)
Dim restrictedCols As Range
If kenshuKbn = "1" Then
Set restrictedCols = Union(Me.Columns("K"), Me.Columns("O"), Me.Columns("P"), Me.Columns("Q"), Me.Columns("R"))
@@ -87,19 +94,231 @@ Finally:
Application.EnableEvents = True '
End Sub
' Prevent insert/delete row in header area
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(Me.CodeName)
Dim filterRow As Long: filterRow = sheetConf("FilterRow")
If Target.Row < filterRow + 1 Then
Cancel = True
MsgBox "Cannot insert or delete row in header area.", vbExclamation
End If
End Sub
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
On Error GoTo ErrHandler
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
Dim startCol As String: startCol = sheetConf("StartCol")
Dim endCol As String: endCol = sheetConf("EndCol")
Dim errorCol As String: errorCol = sheetConf("ErrorCol")
Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol))
clearRange.Interior.Color = vbWhite
Dim errorCell As Range: Set errorCell = ws.Cells(rowNum, errorCol)
' Check C column in the cache
Dim m1Cache As Object: Set m1Cache = GetCache("M1")
' C column check
checkResult = CheckRequired(ws, rowNum, 3, errorCol)
If checkResult = False Then Exit Sub
Dim cValue As String: cValue = Trim(ws.Range("C" & rowNum).Value)
If Not m1Cache.Exists(cValue) Then
errorCell.Value = GetErrorMsg("E004", "C" & rowNum)
ws.Range("C" & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
' Check column required
Dim colLetter As Variant
For Each colLetter In Array("I", "J", "K", "L", "M")
If Trim(ws.Range(colLetter & rowNum).Value) = "" Then
errorCell.Value = GetErrorMsg("E002", colLetter & rowNum)
ws.Range(colLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Next colLetter
' Check column numeric (only if has value)
Dim numericCols As Variant: numericCols = Array("L", "M", "N", "O", "P", "Q", "R")
Dim col As Variant
For Each col In numericCols
Dim val As String: val = Trim(ws.Range(col & rowNum).Value & "")
If val <> "" And Not IsNumeric(val) Then
errorCell.Value = GetErrorMsg("E011", col & rowNum)
ws.Range(col & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Next col
Dim kenshuKbn As String: kenshuKbn = Trim(ws.Range("I" & rowNum).Value)
Dim cache As Object
Dim requiredCols As Variant
Dim equaledCols As Variant
Dim emptyCols As Variant
If kenshuKbn = "1" Then
Set cache = GetCache("T1")
' must input
equaledCols = Array("K")
requiredCols = Array("N")
emptyCols = Array("O", "P", "Q", "R")
End If
If kenshuKbn = "2" Then
Set cache = GetCache("T2")
' must input
equaledCols = Array("K", "L", "M", "N", "O", "P", "Q")
requiredCols = Array("N", "O", "P", "Q")
emptyCols = Array("R")
End If
If kenshuKbn = "3" Then
Set cache = GetCache("T3")
' must input
equaledCols = Array("K", "L", "M")
requiredCols = Array()
emptyCols = Array("N", "O", "P", "Q", "R")
End If
' Check J column in the T1, T2, T3
' code not exist check
Dim code As String: code = Trim(ws.Range("J" & rowNum).Value)
If Not cache.Exists(code) Then
errorCell.Value = GetErrorMsg("E004", "J" & rowNum)
ws.Range("J" & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Dim equaledCol As Variant
Dim equaledIndex As Long
For equaledIndex = LBound(equaledCols) To UBound(equaledCols)
equaledCol = equaledCols(equaledIndex)
' M2 value
Dim equalValue As String: equalValue = Trim(ws.Range(equaledCol & rowNum).Value)
If cache(code)(equaledIndex) <> equalValue Then
errorCell.Value = GetErrorMsg("E004", equaledCol & rowNum)
ws.Range(equaledCol & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Next equaledIndex
Dim requiredCol As Variant
For Each requiredCol In requiredCols
Dim requiredValue As String: requiredValue = Trim(ws.Range(requiredCol & rowNum).Value)
If requiredValue = "" Then
errorCell.Value = GetErrorMsg("E002", requiredCol & rowNum)
ws.Range(requiredCol & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Next requiredCol
Dim emptyCol As Variant
For Each emptyCol In emptyCols
Dim emptyValue As String: emptyValue = Trim(ws.Range(emptyCol & rowNum).Value)
If emptyValue <> "" Then
errorCell.Value = GetErrorMsg("E005", emptyCol & rowNum)
ws.Range(emptyCol & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Next emptyCol
' check Duplicate
Dim sikyuKikan As String: sikyuKikan = Trim(ws.Range("N" & rowNum).Value)
Dim hasError As Boolean: hasError = False
Dim otherValueC As String, otherValueI As String, otherValueJ As String, otherValueN As String
Dim otherRow As Long
For otherRow = 7 To rowNum - 1
otherValueC = Trim(ws.Cells(otherRow, "C").Value)
otherValueI = Trim(ws.Cells(otherRow, "I").Value)
otherValueJ = Trim(ws.Cells(otherRow, "J").Value)
otherValueN = Trim(ws.Cells(otherRow, "N").Value)
If kenshuKbn = "1" Then
If otherValueC = cValue And otherValueI = kenshuKbn And otherValueJ = code And otherValueN = sikyuKikan Then
hasError = True
End If
Else
If otherValueC = cValue And otherValueI = kenshuKbn And otherValueJ = code Then
hasError = True
End If
End If
If hasError = True Then
errorCell.Value = GetErrorMsg("E013", otherRow, code)
ws.Cells(rowNum, "C").Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Next otherRow
' validate passed, clear error cell and setup backcolor
errorCell.ClearContents
Application.EnableEvents = False
Call ChangeBackColor(rowNum)
Application.EnableEvents = True
Exit Sub
ErrHandler:
lastErrorMsg = Err.Description
End Sub
' obtain T1/T2/T3 cache data, and update column K
Private Sub Refresh(ws As Worksheet, ByVal startRow As Long, ByVal lastDataRow As Long)
Dim kenshuList As Object: Set kenshuList = GetCache("kenshuList")
Application.EnableEvents = False
On Error GoTo ErrorHandler
Dim r As Long
For r = startRow To lastDataRow
Dim cValue As String: cValue = Trim(ws.Cells(r, 3).Value) ' Column C
' Skip if C column is empty
If cValue = "" Then
GoTo NextRow
End If
' Reuse FillFromM1 method to fill D-H columns
Call FillFromM1(ws, r)
Call BuildKenshuDropdown(ws, "I", r)
' Reuse FillKFromJ method to fill J-K columns
Dim iValue As String: iValue = Trim(ws.Cells(r, 9).Value) ' Column I
If iValue <> "" And kenshuList.Exists(iValue) Then
Call CreateJDropdown(r)
Call ChangeBackColor(r)
Call FillKFromJ(ws, r)
End If
NextRow:
Next r
Application.EnableEvents = True
Exit Sub
ErrorHandler:
Application.EnableEvents = True
Err.Raise ERR_CACHE_NOT_FOUND, "M2.Refresh", "Failed to refresh M2: " & Err.Description
End Sub
Private Sub FillKFromJ(ByVal ws As Worksheet, ByVal rowNum As Long)
Dim iValue As String: iValue = Trim(ws.Range("I" & rowNum).Value)
Dim kenshu As String: kenshu = Trim(ws.Range("I" & rowNum).Value)
Dim jValue As String: jValue = Trim(ws.Range("J" & rowNum).Value)
Dim code As String: code = GetCode(jValue)
If jValue = "" Then
ws.Range("K" & rowNum).ClearContents
ws.Range(ws.Cells(rowNum, "K"), ws.Cells(rowNum, "R")).ClearContents
Exit Sub
End If
' Get cache based on I column value
Dim cache As Object
Select Case iValue
Select Case kenshu
Case "1"
Set cache = GetCache("T1")
Case "2"
@@ -113,7 +332,6 @@ Private Sub FillKFromJ(ByVal ws As Worksheet, ByVal rowNum As Long)
If cache Is Nothing Then Exit Sub
' Check if J value exists in cache
If cache.Exists(code) Then
Dim cacheVal As Variant: cacheVal = cache(code)
ws.Range("J" & rowNum).Value = Trim(code)
@@ -124,12 +342,12 @@ Private Sub FillKFromJ(ByVal ws As Worksheet, ByVal rowNum As Long)
Case "1"
Exit Sub
Case "2"
ws.Range("L" & rowNum).Value = Trim(cacheVal(2))
ws.Range("M" & rowNum).Value = Trim(cacheVal(3))
ws.Range("N" & rowNum).Value = Trim(cacheVal(4))
ws.Range("O" & rowNum).Value = Trim(cacheVal(5))
ws.Range("P" & rowNum).Value = Trim(cacheVal(6))
ws.Range("Q" & rowNum).Value = Trim(cacheVal(7))
ws.Range("L" & rowNum).Value = Trim(cacheVal(1))
ws.Range("M" & rowNum).Value = Trim(cacheVal(2))
ws.Range("N" & rowNum).Value = Trim(cacheVal(3))
ws.Range("O" & rowNum).Value = Trim(cacheVal(4))
ws.Range("P" & rowNum).Value = Trim(cacheVal(5))
ws.Range("Q" & rowNum).Value = Trim(cacheVal(6))
Case "3"
ws.Range("L" & rowNum).Value = Trim(cacheVal(1))
ws.Range("M" & rowNum).Value = Trim(cacheVal(2))
@@ -139,57 +357,6 @@ Private Sub FillKFromJ(ByVal ws As Worksheet, ByVal rowNum As Long)
End Sub
Private Sub CreateJDropdown(ByVal rowNum As Long)
Dim iValue As String: iValue = Trim(Me.Range("I" & rowNum).Value)
Dim targetCell As Range: Set targetCell = Me.Range("J" & rowNum)
' Clear existing validation
targetCell.Validation.Delete
targetCell.ClearContents
' Get cache based on I column value
Dim cache As Object
Select Case iValue
Case "1"
Set cache = GetCache("T1")
Me.Range("O" & rowNum).Interior.Color = RGB(192, 192, 192)
Me.Range("P" & rowNum).Interior.Color = RGB(192, 192, 192)
Me.Range("Q" & rowNum).Interior.Color = RGB(192, 192, 192)
Case "2"
Set cache = GetCache("T2")
Case "3"
Set cache = GetCache("T3")
Me.Range("N" & rowNum).Interior.Color = RGB(192, 192, 192)
Me.Range("O" & rowNum).Interior.Color = RGB(192, 192, 192)
Me.Range("P" & rowNum).Interior.Color = RGB(192, 192, 192)
Me.Range("Q" & rowNum).Interior.Color = RGB(192, 192, 192)
Case Else
Exit Sub
End Select
If cache Is Nothing Then Exit Sub
' Build dropdown list from cache
Dim dropdownList As String: dropdownList = ""
Dim key As Variant
For Each key In cache.Keys
Dim displayText As String: displayText = MakeSelect(key, cache(key)(0))
If dropdownList = "" Then
dropdownList = displayText
Else
dropdownList = dropdownList & "," & displayText
End If
Next key
If dropdownList <> "" Then
With targetCell.Validation
.Add Type:=xlValidateList, Formula1:=dropdownList
.IgnoreBlank = True
.InCellDropdown = True
End With
End If
End Sub
Private Sub FillFromM1(ByVal ws As Worksheet, ByVal rowNum As Long)
Dim m1Cache As Object: Set m1Cache = GetCache("M1")
Dim cValue As String: cValue = Trim(ws.Range("C" & rowNum).Value)
@@ -233,199 +400,41 @@ Private Sub ClearRowData(ByVal ws As Worksheet, ByVal rowNum As Long)
ws.Cells(rowNum, "S").ClearContents
End Sub
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
Private Sub CreateJDropdown(ByVal rowNum As Long)
Dim kenshu As String: kenshu = Trim(Me.Range("I" & rowNum).Value)
Dim targetCell As Range: Set targetCell = Me.Range("J" & rowNum)
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
' Clear existing validation
targetCell.Validation.Delete
If kenshu = "" Then
Exit Sub
End If
Call BuildDropdownFromCacheNamedRange(Me, "J", rowNum, "T" & kenshu)
End Sub
Dim startCol As String: startCol = sheetConf("StartCol")
Dim endCol As String: endCol = sheetConf("EndCol")
Dim errorCol As String: errorCol = sheetConf("ErrorCol")
Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol))
clearRange.Interior.Color = vbWhite
' Check C column in the cache
Dim m1Cache As Object: Set m1Cache = GetCache("M1")
' C column check
checkResult = CheckRequired(ws, rowNum, 3, errorCol)
If checkResult = False Then Exit Sub
Dim cValue As String: cValue = Trim(ws.Range("C" & rowNum).Value)
If Not m1Cache.Exists(cValue) Then
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E004", "C" & rowNum)
ws.Range("C" & rowNum).Interior.Color = RGB(255, 0, 0)
' change back color by I colum kennshu
Private Sub ChangeBackColor(ByVal rowNum As Long)
Dim kenshu As String: kenshu = Trim(Me.Range("I" & rowNum).Value)
If kenshu = "" Then
Exit Sub
End If
' Check column required
Dim colLetter As Variant
For Each colLetter In Array("I", "J", "K", "L", "M")
If Trim(ws.Range(colLetter & rowNum).Value) = "" Then
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E002", colLetter & rowNum)
ws.Range(colLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Next colLetter
' Check column numeric (only if has value)
Dim numericCols As Variant: numericCols = Array("L", "M", "N", "O", "P", "Q", "R")
Dim col As Variant
For Each col In numericCols
Dim val As String: val = Trim(ws.Range(col & rowNum).Value & "")
If val <> "" And Not IsNumeric(val) Then
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E011", col & rowNum)
ws.Range(col & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Next col
' Check I column in the kenshuKbn
Dim kenshuList As Object: Set kenshuList = GetCache("kenshuList")
Dim kenshuKbn As String: kenshuKbn = Trim(ws.Range("I" & rowNum).Value)
If Not kenshuList.Exists(kenshuKbn) Then
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E012", "I" & rowNum)
ws.Range("I" & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
' Check J column in the T1, T2, T3
Dim code As String: code = Trim(ws.Range("J" & rowNum).Value)
Dim name As String: name = Trim(ws.Range("K" & rowNum).Value)
Dim valueL As String: valueL = Trim(ws.Range("L" & rowNum).Value)
Dim valueM As String: valueM = Trim(ws.Range("M" & rowNum).Value)
Dim valueN As String: valueN = Trim(ws.Range("N" & rowNum).Value)
Dim valueO As String: valueO = Trim(ws.Range("O" & rowNum).Value)
Dim valueP As String: valueP = Trim(ws.Range("P" & rowNum).Value)
Dim valueQ As String: valueQ = Trim(ws.Range("Q" & rowNum).Value)
Me.Range("R" & rowNum).Interior.Color = RGB(192, 192, 192)
' Get cache based on I column value
Dim cache As Object
Dim requiredCols As Variant
Dim equaledCols As Variant
Dim emptyCols As Variant
If kenshuKbn = "1" Then
Set cache = GetCache("T1")
' must input
equaledCols = Array("K")
requiredCols = Array("N")
emptyCols = Array("O", "P", "Q", "R")
End If
If kenshuKbn = "2" Then
Set cache = GetCache("T2")
' must input
equaledCols = Array("K", "L", "M", "N", "O", "P", "Q")
requiredCols = Array("N", "O", "P", "Q")
emptyCols = Array("R")
End If
If kenshuKbn = "3" Then
Set cache = GetCache("T3")
' must input
equaledCols = Array("K", "L", "M")
requiredCols = Array()
emptyCols = Array("N", "O", "P", "Q", "R")
End If
' code not exist check
If Not cache.Exists(code) Then
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E004", "J" & rowNum)
ws.Range("J" & rowNum).Interior.Color = RGB(255, 0, 0)
Select Case kenshu
Case "1"
Me.Range("O" & rowNum).Interior.Color = RGB(192, 192, 192)
Me.Range("P" & rowNum).Interior.Color = RGB(192, 192, 192)
Me.Range("Q" & rowNum).Interior.Color = RGB(192, 192, 192)
Case "2"
Exit Sub
End If
' Dim equaledColIndex As Long
' For equaledColIndex = 0 To
' Dim equaledCol As Variant
' For Each equaledCol In equaledCols
' Dim equalValue As String: equalValue = Trim(ws.Range(equaledCol & rowNum).Value)
' cache
' If cache(code)(0) <> name Then
' Exit Sub
' End If
' Me.Range(equaledCol & rowNum).Validation.Delete
' Next equaledCol
Dim requiredCol As Variant
For Each requiredCol In requiredCols
Dim requiredValue As String: requiredValue = Trim(ws.Range(requiredCol & rowNum).Value)
If requiredValue = "" Then
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E002", requiredCol & rowNum)
ws.Range(requiredCol & rowNum).Interior.Color = RGB(255, 0, 0)
Case "3"
Me.Range("N" & rowNum).Interior.Color = RGB(192, 192, 192)
Me.Range("O" & rowNum).Interior.Color = RGB(192, 192, 192)
Me.Range("P" & rowNum).Interior.Color = RGB(192, 192, 192)
Me.Range("Q" & rowNum).Interior.Color = RGB(192, 192, 192)
Case Else
Exit Sub
End If
Next requiredCol
Dim emptyCol As Variant
For Each emptyCol In emptyCols
Dim emptyValue As String: emptyValue = Trim(ws.Range(emptyCol & rowNum).Value)
If emptyValue <> "" Then
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E005", emptyCol & rowNum)
ws.Range(emptyCol & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Next emptyCol
' check Duplicate
Dim i As Long
For i = 7 To rowNum - 1
If Trim(ws.Cells(i, "C").Value) = cValue And Trim(ws.Cells(i, "I").Value) = kenshuKbn And Trim(ws.Cells(i, "J").Value) = code Then
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E013", i, checkValue)
ws.Cells(rowNum, "C").Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
If Trim(ws.Cells(i, "C").Value) = cValue And Trim(ws.Cells(i, "I").Value) = kenshuKbn And Trim(ws.Cells(i, "K").Value) = name Then
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E013", i, checkValue)
ws.Cells(rowNum, "C").Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Next i
ws.Cells(rowNum, errorCol).ClearContents
End Sub
Public Sub ImportCSVAndTriggerChange(ws As Worksheet, ByVal lastDataRow As Long)
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
Dim startRow As Long: startRow = sheetConf("StartRow")
Dim i As Long
For i = startRow To lastDataRow
Call FillFromM1(ws, i)
Next i
End Sub
' obtain T1/T2/T3 cache data, and update column K
Private Sub Refresh(ws As Worksheet, ByVal startRow As Long, ByVal lastDataRow As Long)
Dim kenshuList As Object: Set kenshuList = GetCache("kenshuList")
If kenshuList Is Nothing Then Exit Sub
Application.EnableEvents = False
On Error GoTo Finally
Dim r As Long
For r = startRow To lastDataRow
Dim cValue As String: cValue = Trim(ws.Cells(r, 3).Value) ' Column C
' Skip if C column is empty
If cValue = "" Then
GoTo NextRow
End If
' Reuse FillFromM1 method to fill D-H columns
Call FillFromM1(ws, r)
' Reuse FillKFromJ method to fill J-K columns
Dim iValue As String: iValue = Trim(ws.Cells(r, 9).Value) ' Column I
If iValue <> "" And kenshuList.Exists(iValue) Then
Call FillKFromJ(ws, r)
End If
NextRow:
Next r
Finally:
Application.EnableEvents = True
End Select
End Sub

22
src/sh/tuk/sheet/O1.cls
View File

@@ -11,5 +11,25 @@
Private Sub Worksheet_Change(ByVal Target As Range)
Dim HasHeaderEdit As Boolean: HasHeaderEdit = CheckHeaderEdit(Me, Target)
If HasHeaderEdit = True Then Exit Sub
End Sub
' Prevent insert/delete row in header area
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(Me.CodeName)
Dim filterRow As Long: filterRow = sheetConf("FilterRow")
If Target.Row < filterRow + 1 Then
Cancel = True
MsgBox "Cannot insert or delete row in header area.", vbExclamation
End If
End Sub
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
On Error GoTo ErrHandler
Exit Sub
ErrHandler:
lastErrorMsg = Err.Description
End Sub

21
src/sh/tuk/sheet/O2.cls
View File

@@ -13,3 +13,24 @@ Private Sub Worksheet_Change(ByVal Target As Range)
If HasHeaderEdit = True Then Exit Sub
End Sub
' Prevent insert/delete row in header area
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(Me.CodeName)
Dim filterRow As Long: filterRow = sheetConf("FilterRow")
If Target.Row < filterRow + 1 Then
Cancel = True
MsgBox "Cannot insert or delete row in header area.", vbExclamation
End If
End Sub
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
On Error GoTo ErrHandler
Exit Sub
ErrHandler:
lastErrorMsg = Err.Description
End Sub

17
src/sh/tuk/sheet/T1.cls
View File

@@ -15,8 +15,21 @@ Private Sub Worksheet_Change(ByVal Target As Range)
End Sub
' Prevent insert/delete row in header area
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(Me.CodeName)
Dim filterRow As Long: filterRow = sheetConf("FilterRow")
If Target.Row < filterRow + 1 Then
Cancel = True
MsgBox "Cannot insert or delete row in header area.", vbExclamation
End If
End Sub
'
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
On Error GoTo ErrHandler
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
@@ -62,4 +75,8 @@ Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
If checkResult = False Then Exit Sub
ws.Cells(rowNum, errorCol).ClearContents
Exit Sub
ErrHandler:
lastErrorMsg = Err.Description
End Sub

17
src/sh/tuk/sheet/T2.cls
View File

@@ -15,8 +15,21 @@ Private Sub Worksheet_Change(ByVal Target As Range)
End Sub
' Prevent insert/delete row in header area
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(Me.CodeName)
Dim filterRow As Long: filterRow = sheetConf("FilterRow")
If Target.Row < filterRow + 1 Then
Cancel = True
MsgBox "Cannot insert or delete row in header area.", vbExclamation
End If
End Sub
'
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
On Error GoTo ErrHandler
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
@@ -122,4 +135,8 @@ Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
If checkResult = False Then Exit Sub
ws.Cells(rowNum, errorCol).ClearContents
Exit Sub
ErrHandler:
lastErrorMsg = Err.Description
End Sub

17
src/sh/tuk/sheet/T3.cls
View File

@@ -15,8 +15,21 @@ Private Sub Worksheet_Change(ByVal Target As Range)
End Sub
' Prevent insert/delete row in header area
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(Me.CodeName)
Dim filterRow As Long: filterRow = sheetConf("FilterRow")
If Target.Row < filterRow + 1 Then
Cancel = True
MsgBox "Cannot insert or delete row in header area.", vbExclamation
End If
End Sub
'
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
On Error GoTo ErrHandler
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
@@ -82,4 +95,8 @@ Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
If checkResult = False Then Exit Sub
ws.Cells(rowNum, errorCol).ClearContents
Exit Sub
ErrHandler:
lastErrorMsg = Err.Description
End Sub

17
src/sh/tuk/sheet/Z1.cls
View File

@@ -15,8 +15,21 @@ Private Sub Worksheet_Change(ByVal Target As Range)
End Sub
' Prevent insert/delete row in header area
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(Me.CodeName)
Dim filterRow As Long: filterRow = sheetConf("FilterRow")
If Target.Row < filterRow + 1 Then
Cancel = True
MsgBox "Cannot insert or delete row in header area.", vbExclamation
End If
End Sub
'
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
On Error GoTo ErrHandler
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
@@ -72,4 +85,8 @@ Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
If checkResult = False Then Exit Sub
ws.Cells(rowNum, errorCol).ClearContents
Exit Sub
ErrHandler:
lastErrorMsg = Err.Description
End Sub

17
src/sh/tuk/sheet/Z2.cls
View File

@@ -15,8 +15,21 @@ Private Sub Worksheet_Change(ByVal Target As Range)
End Sub
' Prevent insert/delete row in header area
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(Me.CodeName)
Dim filterRow As Long: filterRow = sheetConf("FilterRow")
If Target.Row < filterRow + 1 Then
Cancel = True
MsgBox "Cannot insert or delete row in header area.", vbExclamation
End If
End Sub
'
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
On Error GoTo ErrHandler
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
@@ -62,4 +75,8 @@ Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
If checkResult = False Then Exit Sub
ws.Cells(rowNum, errorCol).ClearContents
Exit Sub
ErrHandler:
lastErrorMsg = Err.Description
End Sub

18
src/sh/tuk/sheet/Z3.cls
View File

@@ -15,8 +15,22 @@ Private Sub Worksheet_Change(ByVal Target As Range)
End Sub
' Prevent insert/delete row in header area
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(Me.CodeName)
Dim filterRow As Long: filterRow = sheetConf("FilterRow")
If Target.Row < filterRow + 1 Then
Cancel = True
MsgBox "Cannot insert or delete row in header area.", vbExclamation
End If
End Sub
'
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
On Error GoTo ErrHandler
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
@@ -65,4 +79,8 @@ Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
If checkResult = False Then Exit Sub
ws.Cells(rowNum, errorCol).ClearContents
Exit Sub
ErrHandler:
lastErrorMsg = Err.Description
End Sub

18
src/sh/tuk/sheet/Z4.cls
View File

@@ -15,8 +15,22 @@ Private Sub Worksheet_Change(ByVal Target As Range)
End Sub
' Prevent insert/delete row in header area
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(Me.CodeName)
Dim filterRow As Long: filterRow = sheetConf("FilterRow")
If Target.Row < filterRow + 1 Then
Cancel = True
MsgBox "Cannot insert or delete row in header area.", vbExclamation
End If
End Sub
'
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
On Error GoTo ErrHandler
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
@@ -69,4 +83,8 @@ Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
If checkResult = False Then Exit Sub
ws.Cells(rowNum, errorCol).ClearContents
Exit Sub
ErrHandler:
lastErrorMsg = Err.Description
End Sub

BIN
通勤手当テンプレート20260515.xlsm
View File

Binary file not shown.