diff --git a/AGENTS.md b/AGENTS.md index 3f5223f..0b04025 100644 --- a/AGENTS.md +++ b/AGENTS.md @@ -58,6 +58,8 @@ Before editing any sheet class or cache logic, **read the design document first* **Rule**: Do not guess sheet layout or cache structure. Look it up in the design document. +**When cache structure is modified**: Update the design document accordingly — including CACHE_* constant table, cache architecture section, and any affected data flow diagrams. + vba/ AGENTS.md, README.md, .gitignore, LICENSE 通勤手当テンプレート2026xxxx.xlsm (latest date version) diff --git a/src/sh/tuk/init_module/Import_modules.bas b/src/sh/tuk/init_module/Import_modules.bas index 290fcaa..9f519a4 100644 --- a/src/sh/tuk/init_module/Import_modules.bas +++ b/src/sh/tuk/init_module/Import_modules.bas @@ -7,14 +7,13 @@ Sub ImportModulesAndSheets_Safe() Dim basePath As String: basePath = ThisWorkbook.Path If Right(basePath, 1) <> "\" Then basePath = basePath & "\" - Const PROJECT_PATH As String = basePath - Const MODULE_PATH As String = basePath & "src\sh\tuk\module" - Const SHEET_PATH As String = basePath & "src\sh\tuk\sheet" - + Dim modulePath As String: modulePath = basePath & "src\sh\tuk\module" + Dim sheetPath As String: sheetPath = basePath & "src\sh\tuk\sheet" + ' --- Phase 1: Validation --- Debug.Print "[LOG] Starting validation phase..." Dim validationErrors As String - validationErrors = ValidateAllFilesAndTargets(MODULE_PATH, SHEET_PATH) + validationErrors = ValidateAllFilesAndTargets(modulePath, sheetPath) If validationErrors <> "" Then MsgBox "Validation failed. Import aborted:" & vbCrLf & vbCrLf & validationErrors, vbCritical @@ -27,8 +26,9 @@ Sub ImportModulesAndSheets_Safe() Application.ScreenUpdating = False Debug.Print "[LOG] Validation passed. Starting import phase..." - ImportStandardModules MODULE_PATH - ImportSheetCLSFiles SHEET_PATH + ImportStandardModules modulePath + ImportSheetCLSFiles sheetPath + ImportValidationClasses sheetPath Application.ScreenUpdating = True MsgBox "All .bas and .cls files imported successfully!", vbInformation @@ -198,4 +198,45 @@ Private Function ExtractPureCodeFromCls(filePath As String) As String ts.Close ExtractPureCodeFromCls = result -End Function \ No newline at end of file +End Function + +' Import ValidationRuleEngine.cls, ValidationRule.cls, ValidationResult.cls +' as class modules (not sheet classes) +Private Sub ImportValidationClasses(sheetPath As String) + Dim fso As Object + Set fso = CreateObject("Scripting.FileSystemObject") + + Dim valPath As String: valPath = sheetPath & "\..\validation" + Debug.Print "[LOG] Starting import of validation classes from: " & valPath + + Dim classFiles As Variant + classFiles = Array("ValidationResult.cls", "ValidationRule.cls", "ValidationRuleEngine.cls") + + Dim i As Long + For i = 0 To UBound(classFiles) + Dim filePath As String: filePath = valPath & "\" & classFiles(i) + + If Not fso.FileExists(filePath) Then + Debug.Print "[WARNING] Validation class not found: " & filePath + Else + Dim clsName As String: clsName = fso.GetBaseName(classFiles(i)) + + ' Remove existing class component if any + On Error Resume Next + ThisWorkbook.VBProject.VBComponents.Remove ThisWorkbook.VBProject.VBComponents(clsName) + On Error GoTo 0 + + DoEvents + Application.Wait Now + TimeSerial(0, 0, 1) + + ' Import as class module + ThisWorkbook.VBProject.VBComponents.Import filePath + + DoEvents + + Debug.Print "[LOG] Successfully imported validation class: " & clsName + End If + Next i + + Debug.Print "[LOG] Finished importing validation classes." +End Sub \ No newline at end of file diff --git a/src/sh/tuk/module/Common_Button.bas b/src/sh/tuk/module/Common_Button.bas index ebc1420..fa078f2 100644 --- a/src/sh/tuk/module/Common_Button.bas +++ b/src/sh/tuk/module/Common_Button.bas @@ -1,8 +1,23 @@ Attribute VB_Name = "Common_Button" Option Explicit -' --- Public Variables --- -Public lastErrorMsg As String +' --- Private Variables --- +Private m_LastErrorMsg As String + +' ============================================================ +' Get/Set last error message +' ============================================================ +Public Sub SetLastErrorMsg(msg As String) + m_LastErrorMsg = msg +End Sub + +Public Function GetLastErrorMsg() As String + GetLastErrorMsg = m_LastErrorMsg +End Function + +Public Sub ClearLastErrorMsg() + m_LastErrorMsg = "" +End Sub ' ============================================================ ' Module Name: Common_Button @@ -67,6 +82,7 @@ Sub RefreshCache_Button() Exit Sub ErrorHandler: + Debug.Print "sheetName = " & sheetName HandleError "RefreshCache_Button" End Sub @@ -373,10 +389,10 @@ Public Function RunValidationSilent(ws As Worksheet) As Long Dim r As Long Dim hasError As Boolean: hasError = False For r = startRow To lastDataRow - lastErrorMsg = "" - Application.Run validate, ws, r, lastDataRow - If lastErrorMsg <> "" Then - Err.Raise ERR_VALIDATION_FAILED, "RunValidationSilent", lastErrorMsg + SetLastErrorMsg "" + Application.Run validate, ws, r, lastDataRow + If GetLastErrorMsg() <> "" Then + Err.Raise ERR_VALIDATION_FAILED, "RunValidationSilent", GetLastErrorMsg() End If Dim errorMessage As String: errorMessage = Trim(ws.Cells(r, errorCol).Value) Dim errorCode As String: errorCode = GetCode(errorMessage) diff --git a/src/sh/tuk/module/Common_File_Utils.bas b/src/sh/tuk/module/Common_File_Utils.bas index bd1ed64..860369d 100644 --- a/src/sh/tuk/module/Common_File_Utils.bas +++ b/src/sh/tuk/module/Common_File_Utils.bas @@ -52,8 +52,8 @@ Sub WriteCSVFromArray( _ If rows = 0 Or cols = 0 Then Exit Sub ' Empty array, exit early ' === Build CSV content === - Dim outputLines As Collection - Set outputLines = New Collection + Dim outputLines As VBA.Collection + Set outputLines = New VBA.Collection Dim i As Long, j As Long Dim rowStr As String @@ -129,8 +129,8 @@ ExitPoint: ArrayDimensions = dimCount - 1 End Function -' Helper function: convert a Collection to a 1D array (for use with Join) -Private Function CollectionToArray(col As Collection) As Variant +' Helper function: convert a VBA.Collection to a 1D array (for use with Join) +Private Function CollectionToArray(col As VBA.Collection) As Variant If col.Count = 0 Then CollectionToArray = Array() Exit Function @@ -210,7 +210,7 @@ Function ReadCSVAs2DArrayStrict( _ textContent = Replace(textContent, vbCr, vbLf) ' === transfer into collection === - Dim lines As Collection + Dim lines As VBA.Collection Set lines = ParseCSVLines(textContent) ' === validate empty === @@ -259,14 +259,14 @@ Function ReadCSVAs2DArrayStrict( _ End Function ' Helper function: Parse CSV text into collection of string arrays (zero-based per row) -Private Function ParseCSVLines(ByVal csvText As String) As Collection - Set ParseCSVLines = New Collection +Private Function ParseCSVLines(ByVal csvText As String) As VBA.Collection + Set ParseCSVLines = New VBA.Collection Dim length As Long: length = Len(csvText) If length = 0 Then Exit Function Dim i As Long: i = 1 Dim currentField As String - Dim currentRow As Collection: Set currentRow = New Collection + Dim currentRow As VBA.Collection: Set currentRow = New VBA.Collection Dim inQuotes As Boolean Dim c As String @@ -314,7 +314,7 @@ Private Function ParseCSVLines(ByVal csvText As String) As Collection Next k End If ParseCSVLines.Add arr - Set currentRow = New Collection + Set currentRow = New VBA.Collection currentField = "" inQuotes = False i = i + 1 diff --git a/src/sh/tuk/module/Common_Functions.bas b/src/sh/tuk/module/Common_Functions.bas index b2f3044..2a902cf 100644 --- a/src/sh/tuk/module/Common_Functions.bas +++ b/src/sh/tuk/module/Common_Functions.bas @@ -429,6 +429,11 @@ Function ColLetter(colNum As Long) As String ColLetter = Split(Cells(1, colNum).Address, "$")(1) End Function +'Convert column letter to number +Function ColNum(colLetter As String) As Long + ColNum = Range(colLetter & "1").Column +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) diff --git a/src/sh/tuk/module/ValidationRuleEnums.bas b/src/sh/tuk/module/ValidationRuleEnums.bas new file mode 100644 index 0000000..fbeafed --- /dev/null +++ b/src/sh/tuk/module/ValidationRuleEnums.bas @@ -0,0 +1,17 @@ +Attribute VB_Name = "ValidationRuleEnums" +' ValidationRuleEnums.bas +' Standard module for shared rule-type constants. +' Using Long constants instead of Enum to avoid VBA class-module ambiguity issues. +Option Explicit + +Public Const ValRule_Required As Long = 0 +Public Const ValRule_Date As Long = 1 +Public Const ValRule_Number As Long = 2 +Public Const ValRule_CodeSelect As Long = 3 +Public Const ValRule_Range As Long = 4 +Public Const ValRule_Duplicate As Long = 5 +Public Const ValRule_Char As Long = 6 +Public Const ValRule_Varchar As Long = 7 +Public Const ValRule_Check01 As Long = 8 +Public Const ValRule_Alphanumeric As Long = 9 +Public Const ValRule_Custom As Long = 11 \ No newline at end of file diff --git a/src/sh/tuk/sheet/C1.cls b/src/sh/tuk/sheet/C1.cls index c1e452b..65cc7d6 100644 --- a/src/sh/tuk/sheet/C1.cls +++ b/src/sh/tuk/sheet/C1.cls @@ -1043,7 +1043,7 @@ Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Exit Sub ErrHandler: - lastErrorMsg = Err.Description + SetLastErrorMsg Err.Description End Sub ' Create teiki dropdown based on M2 cache diff --git a/src/sh/tuk/sheet/M1.cls b/src/sh/tuk/sheet/M1.cls index d6b695b..65b9210 100644 --- a/src/sh/tuk/sheet/M1.cls +++ b/src/sh/tuk/sheet/M1.cls @@ -86,22 +86,6 @@ Private Sub Worksheet_Change(ByVal Target As Range) Next End If - ' === Column E changes (rosen name): Build F column (station from) dropdown === - ' If Target.Column = 4 And Target.Row >= 7 Then - ' Dim cellE As Range - ' For Each cellE In Target - ' Dim rosenVal As String: rosenVal = Trim(cellE.Value) - ' If rosenVal = "" Then - ' Me.Cells(cellE.Row, 6).ClearContents - ' Me.Cells(cellE.Row, 8).ClearContents - ' Me.Cells(cellE.Row, 6).Validation.Delete - ' Me.Cells(cellE.Row, 8).Validation.Delete - ' Else - ' Call BuildZ4StationFromDropdown(Me, "F", cellE.Row, rosenVal) - ' End If - ' Next - ' End If - ' === Column F changes (station from): Build H column (station to) dropdown === If Target.Column = 6 And Target.Row >= 7 Then Dim cellF As Range @@ -137,98 +121,81 @@ Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) End If End Sub -Private Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long) +' +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 engine As ValidationRuleEngine: Set engine = New ValidationRuleEngine + With engine + .AddRequired "C" + .AddChar "C", 5 + .AddAlphanumeric "C" + .AddDuplicate "C" + .AddRequired "D" + .AddCodeSelect "D", CACHE_Z1 + .AddRequired "E" + .AddCodeSelect "E", CACHE_Z4ROSEN + .AddRequired "F" + .AddRequired "G" + .AddRequired "I" + .AddRequired "L" + .AddCodeSelect "K", "renrakuList" + .AddCodeSelect "L", "tokubetuList" + .AddNumber "H", 6, 1 + .AddNumber "I", 5 + .AddNumber "J", 6 + .AddNumber "N" + + End With - Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol)) - clearRange.Interior.Color = vbWhite + Dim result As ValidationResult: Set result = engine.ValidateRow(ws, rowNum, lastDataRow) - Dim errorCell As Range: Set errorCell = ws.Cells(rowNum, errorCol) + ' === Special cases (cross-column / cross-cache) === + If result.ErrorCode = "" Then + Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig() + Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName) + Dim errorCol As String: errorCol = sheetConf("ErrorCol") + 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 - 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 - 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 - errorCell.Value = GetErrorMsg("E011", colLetter & rowNum) - ws.Range(colLetter & rowNum).Interior.Color = RGB(255, 0, 0) - Exit Sub - End If - Next colLetter - - ' Check C column repeat - Dim cValue As String: cValue = Trim(ws.Range("C" & rowNum).Value) - Dim foundCell As Range - 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 - errorCell.Value = "C column value is duplicated" - ws.Range("C" & rowNum).Interior.Color = RGB(255, 0, 0) - Exit Sub - End If - End If - - ' Check D and E column in the cache - Dim z1Cache As Object: Set z1Cache = GetCache(CACHE_Z1) - - Dim dValue As String: dValue = Trim(ws.Range("D" & rowNum).Value) - Dim eValue As String: eValue = Trim(ws.Range("E" & rowNum).Value) - - If Not z1Cache.Exists(dValue) Then - 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 - errorCell.Value = "Invalid reference data for D column." - Exit Sub - End If - - Dim expectedEValue As String - expectedEValue = Trim(CStr(valueArray(0))) - - If eValue <> expectedEValue Then - errorCell.Value = "E column does not match reference data." + ' E: must equal CACHE_Z1(D) value + Dim z1Cache As Object: Set z1Cache = GetCache(CACHE_Z1) + Dim dValue As String: dValue = Trim(ws.Range("D" & rowNum).Value) + Dim valArray As Variant: valArray = z1Cache(dValue) + Dim expectedE As String: expectedE = Trim(CStr(valArray(0))) + Dim eValue As String: eValue = Trim(ws.Range("E" & rowNum).Value) + If eValue <> expectedE Then + errorCell.Value = GetErrorMsg(ERR_NOT_EXIST, "E" & CStr(rowNum)) ws.Range("E" & rowNum).Interior.Color = RGB(255, 0, 0) Exit Sub End If + + ' F, G: must be valid stations in the rosen (E), F cannot equal G + Dim z4Rosen As Object: Set z4Rosen = GetCache(CACHE_Z4ROSEN) + Dim stations As Object: Set stations = z4Rosen(eValue) + Dim fValue As String: fValue = Trim(ws.Range("F" & rowNum).Value) + Dim gValue As String: gValue = Trim(ws.Range("G" & rowNum).Value) + If Not stations.Exists(fValue) Then + errorCell.Value = GetErrorMsg(ERR_NOT_EXIST, "F" & CStr(rowNum)) + ws.Range("F" & rowNum).Interior.Color = RGB(255, 0, 0) + Exit Sub + End If + If Not stations.Exists(gValue) Then + errorCell.Value = GetErrorMsg(ERR_NOT_EXIST, "G" & CStr(rowNum)) + ws.Range("G" & rowNum).Interior.Color = RGB(255, 0, 0) + Exit Sub + End If + If fValue = gValue Then + errorCell.Value = GetErrorMsg(ERR_INVALID, "G" & CStr(rowNum)) + ws.Range("F" & rowNum).Interior.Color = RGB(255, 0, 0) + ws.Range("G" & rowNum).Interior.Color = RGB(255, 0, 0) + Exit Sub + End If End If - ' Check L column in the tokubetuList - 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 - errorCell.Value = "L column does not exist." - ws.Range("L" & rowNum).Interior.Color = RGB(255, 0, 0) - Exit Sub - End If - - ' Validation passed - clear error - If Not StartsWith(errorCell.Value, "W") Then - errorCell.ClearContents - End If Exit Sub ErrHandler: - lastErrorMsg = Err.Description + SetLastErrorMsg Err.Description End Sub ' obtain z1 master data, and update column E @@ -239,11 +206,20 @@ Private Sub Refresh(ws As Worksheet, ByVal startRow As Long, ByVal lastDataRow A On Error GoTo ErrorHandler Dim r As Long + Dim z4Rosen As Object: Set z4Rosen = GetCache(CACHE_Z4ROSEN) For r = startRow To lastDataRow Dim dVal As String: dVal = Trim(ws.Cells(r, 4).Value) ' Column D If dVal <> "" And z1Cache.Exists(dVal) Then Dim valsD As Variant: valsD = z1Cache(dVal) ws.Cells(r, 5).Value = valsD(0) ' Column E + Dim kikanName As String: kikanName = valsD(0) + If z4Rosen.Exists(kikanName) Then + Call BuildZ4StationFromDropdown(ws, "F", r, kikanName) + Dim stationFrom As String: stationFrom = Trim(ws.Cells(r, 6).Value) + If stationFrom <> "" Then + Call BuildZ4StationToDropdown(ws, "G", r, kikanName, stationFrom) + End If + End If End If Call BuildTokubetuDropdown(ws, "L", r) Call BuildRenrakuDropdown(ws, "K", r) diff --git a/src/sh/tuk/sheet/M2.cls b/src/sh/tuk/sheet/M2.cls index 17beaf4..2081e87 100644 --- a/src/sh/tuk/sheet/M2.cls +++ b/src/sh/tuk/sheet/M2.cls @@ -108,163 +108,142 @@ 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 engine As ValidationRuleEngine: Set engine = New ValidationRuleEngine + With engine + .AddRequired "C" + .AddDuplicate "C" + .AddCodeSelect "C", CACHE_M1 + .AddRequired "I" + .AddRequired "J" + .AddRequired "K" + .AddRequired "L" + .AddRequired "M" + .AddNumber "L" + .AddNumber "M" + .AddNumber "N" + .AddNumber "O" + .AddNumber "P" + .AddNumber "Q" + .AddNumber "R" + End With - Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol)) - clearRange.Interior.Color = vbWhite + Dim result As ValidationResult: Set result = engine.ValidateRow(ws, rowNum, lastDataRow) - Dim errorCell As Range: Set errorCell = ws.Cells(rowNum, errorCol) + ' === Special cases (cross-cache / cross-column) === + If result.ErrorCode = "" Then + Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig() + Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName) + Dim errorCol As String: errorCol = sheetConf("ErrorCol") + Dim errorCell As Range: Set errorCell = ws.Cells(rowNum, errorCol) - ' Check C column in the cache - Dim m1Cache As Object: Set m1Cache = GetCache("M1") + ' J: must exist in T1/T2/T3 cache (determined by I column) + Dim kenshuKbn As String: kenshuKbn = Trim(ws.Range("I" & rowNum).Value) + Dim cache As Object + Select Case kenshuKbn + Case "1": Set cache = GetCache(CACHE_T1) + Case "2": Set cache = GetCache(CACHE_T2) + Case "3": Set cache = GetCache(CACHE_T3) + Case Else + errorCell.Value = GetErrorMsg(ERR_NOT_EXIST, "I" & rowNum) + ws.Range("I" & rowNum).Interior.Color = RGB(255, 0, 0) + Exit Sub + End Select - ' 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) + Dim code As String: code = Trim(ws.Range("J" & rowNum).Value) + If Not cache.Exists(code) Then + errorCell.Value = GetErrorMsg(ERR_NOT_EXIST, "J" & rowNum) + ws.Range("J" & 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(CACHE_T1) - ' must input - equaledCols = Array("K") - requiredCols = Array("N") - emptyCols = Array("O", "P", "Q", "R") - End If - - If kenshuKbn = "2" Then - Set cache = GetCache(CACHE_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(CACHE_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) + ' kenshuKbn-specific: equaledCols, requiredCols, emptyCols + Dim equaledCols As Variant + Dim requiredCols As Variant + Dim emptyCols As Variant 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 + equaledCols = Array("K") + requiredCols = Array("N") + emptyCols = Array("O", "P", "Q", "R") + ElseIf kenshuKbn = "2" Then + equaledCols = Array("K", "L", "M", "N", "O", "P", "Q") + requiredCols = Array("N", "O", "P", "Q") + emptyCols = Array("R") + ElseIf kenshuKbn = "3" Then + equaledCols = Array("K", "L", "M") + requiredCols = Array() + emptyCols = Array("N", "O", "P", "Q", "R") 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 - + ' equaledCols must match cache values + Dim equaledIndex As Long + For equaledIndex = LBound(equaledCols) To UBound(equaledCols) + Dim equaledCol As String: equaledCol = equaledCols(equaledIndex) + Dim equalValue As String: equalValue = Trim(ws.Range(equaledCol & rowNum).Value) + If cache(code)(equaledIndex) <> equalValue Then + errorCell.Value = GetErrorMsg(ERR_INVALID, equaledCol & rowNum) + ws.Range(equaledCol & rowNum).Interior.Color = RGB(255, 0, 0) + Exit Sub + End If + Next equaledIndex + + ' requiredCols must not be empty + 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(ERR_REQUIRED, requiredCol & rowNum) + ws.Range(requiredCol & rowNum).Interior.Color = RGB(255, 0, 0) + Exit Sub + End If + Next requiredCol + + ' emptyCols must be empty + 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 + + ' Duplicate: C + I + J (+ N if kenshuKbn=1) + 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 + End If + ' 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 + SetLastErrorMsg Err.Description End Sub ' obtain T1/T2/T3 cache data, and update column K diff --git a/src/sh/tuk/sheet/O1.cls b/src/sh/tuk/sheet/O1.cls index c233aa9..d93bc2a 100644 --- a/src/sh/tuk/sheet/O1.cls +++ b/src/sh/tuk/sheet/O1.cls @@ -31,5 +31,5 @@ Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Exit Sub ErrHandler: - lastErrorMsg = Err.Description + SetLastErrorMsg Err.Description End Sub diff --git a/src/sh/tuk/sheet/O2.cls b/src/sh/tuk/sheet/O2.cls index 106d756..4362936 100644 --- a/src/sh/tuk/sheet/O2.cls +++ b/src/sh/tuk/sheet/O2.cls @@ -32,5 +32,5 @@ Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Exit Sub ErrHandler: - lastErrorMsg = Err.Description + SetLastErrorMsg Err.Description End Sub \ No newline at end of file diff --git a/src/sh/tuk/sheet/O3.cls b/src/sh/tuk/sheet/O3.cls index b665449..b641d4d 100644 --- a/src/sh/tuk/sheet/O3.cls +++ b/src/sh/tuk/sheet/O3.cls @@ -34,5 +34,5 @@ Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Exit Sub ErrHandler: - lastErrorMsg = Err.Description + SetLastErrorMsg Err.Description End Sub diff --git a/src/sh/tuk/sheet/T1.cls b/src/sh/tuk/sheet/T1.cls index 076b566..821db77 100644 --- a/src/sh/tuk/sheet/T1.cls +++ b/src/sh/tuk/sheet/T1.cls @@ -59,58 +59,28 @@ Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) 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") - - ' clear C~G columns background color - Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol)) - clearRange.Interior.Color = vbWhite + ' Build engine: same order as original Validate + Dim engine As ValidationRuleEngine: Set engine = New ValidationRuleEngine + With engine + .AddRequired "C" ' C: required + .AddChar "C", 3 ' C: exact 3 chars + .AddAlphanumeric "C" ' C: alphanumeric only + .AddDuplicate "C" ' C: no duplicate in prior rows + .AddRequired "D" ' D: required + .AddVarchar "D", 80 ' D: max 80 chars + .AddVarchar "E", 80 ' E: max 80 chars + .AddVarchar "F", 80 ' F: max 80 chars + .AddCheck01 "G" ' G: 0 or 1 only + End With - Dim checkResult As Boolean: checkResult = False + Call engine.ValidateRow(ws, rowNum, lastDataRow) - ' C column check - checkResult = CheckRequired(ws, rowNum, 3, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckChar(ws, rowNum, 3, 3, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckAlphanumeric(ws, rowNum, 3, 3, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckDuplicate(ws, rowNum, 3, errorCol) - If checkResult = False Then Exit Sub - - ' D column check - checkResult = CheckRequired(ws, rowNum, 4, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckVarcharOver(ws, rowNum, 4, 80, errorCol) - If checkResult = False Then Exit Sub - - ' E column check - checkResult = CheckVarcharOver(ws, rowNum, 5, 80, errorCol) - If checkResult = False Then Exit Sub - - ' F column check - checkResult = CheckVarcharOver(ws, rowNum, 6, 80, errorCol) - If checkResult = False Then Exit Sub - - ' G column check - checkResult = Check01(ws, rowNum, 7, errorCol) - If checkResult = False Then Exit Sub - - ws.Cells(rowNum, errorCol).ClearContents Exit Sub ErrHandler: - lastErrorMsg = Err.Description + SetLastErrorMsg Err.Description End Sub \ No newline at end of file diff --git a/src/sh/tuk/sheet/T2.cls b/src/sh/tuk/sheet/T2.cls index 81fd8e4..32b7098 100644 --- a/src/sh/tuk/sheet/T2.cls +++ b/src/sh/tuk/sheet/T2.cls @@ -74,115 +74,38 @@ Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) 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") - - ' clear C~M columns background color - Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol)) - clearRange.Interior.Color = vbWhite + Dim engine As ValidationRuleEngine: Set engine = New ValidationRuleEngine + With engine + .AddRequired "C" + .AddAlphanumeric "C" + .AddDuplicate "C" + .AddRequired "D" + .AddVarchar "D", 80 + .AddVarchar "E", 80 + .AddVarchar "F", 80 + .AddCheck01 "G" + .AddRequired "H" + .AddNumber "H", 6 + .AddRequired "I" + .AddNumber "I", 5 + .AddRequired "J" + .AddNumber "J", 3 + .AddRequired "K" + .AddNumber "K", 5 + .AddRequired "L" + .AddNumber "L", 3 + .AddRequired "M" + .AddNumber "M", 5 + End With - Dim checkResult As Boolean: checkResult = False + Call engine.ValidateRow(ws, rowNum, lastDataRow) - ' C column check - checkResult = CheckRequired(ws, rowNum, 3, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckAlphanumeric(ws, rowNum, 3, 3, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckDuplicate(ws, rowNum, 3, errorCol) - If checkResult = False Then Exit Sub - - ' D column check - checkResult = CheckRequired(ws, rowNum, 4, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckVarcharOver(ws, rowNum, 4, 80, errorCol) - If checkResult = False Then Exit Sub - - ' E column check - checkResult = CheckVarcharOver(ws, rowNum, 5, 80, errorCol) - If checkResult = False Then Exit Sub - - ' F column check - checkResult = CheckVarcharOver(ws, rowNum, 6, 80, errorCol) - If checkResult = False Then Exit Sub - - ' G column check - checkResult = Check01(ws, rowNum, 7, errorCol) - If checkResult = False Then Exit Sub - - ' H column check number - checkResult = CheckRequired(ws, rowNum, 8, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckNumber(ws, rowNum, 8, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckNumberOver(ws, rowNum, 8, 6, errorCol) - If checkResult = False Then Exit Sub - - ' I column check number - checkResult = CheckRequired(ws, rowNum, 9, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckNumber(ws, rowNum, 9, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckNumberOver(ws, rowNum, 9, 5, errorCol) - If checkResult = False Then Exit Sub - - ' J column check number - checkResult = CheckRequired(ws, rowNum, 10, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckNumber(ws, rowNum, 10, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckNumberOver(ws, rowNum, 10, 3, errorCol) - If checkResult = False Then Exit Sub - - ' K column check number - checkResult = CheckRequired(ws, rowNum, 11, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckNumber(ws, rowNum, 11, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckNumberOver(ws, rowNum, 11, 5, errorCol) - If checkResult = False Then Exit Sub - - ' L column check number - checkResult = CheckRequired(ws, rowNum, 12, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckNumber(ws, rowNum, 12, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckNumberOver(ws, rowNum, 12, 3, errorCol) - If checkResult = False Then Exit Sub - - ' M column check number - checkResult = CheckRequired(ws, rowNum, 13, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckNumber(ws, rowNum, 13, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckNumberOver(ws, rowNum, 13, 5, errorCol) - If checkResult = False Then Exit Sub - - ws.Cells(rowNum, errorCol).ClearContents Exit Sub ErrHandler: - lastErrorMsg = Err.Description + SetLastErrorMsg Err.Description End Sub \ No newline at end of file diff --git a/src/sh/tuk/sheet/T3.cls b/src/sh/tuk/sheet/T3.cls index 853e1a1..45064df 100644 --- a/src/sh/tuk/sheet/T3.cls +++ b/src/sh/tuk/sheet/T3.cls @@ -59,78 +59,31 @@ Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) 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") - - ' clear C~I columns background color - Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol)) - clearRange.Interior.Color = vbWhite + Dim engine As ValidationRuleEngine: Set engine = New ValidationRuleEngine + With engine + .AddRequired "C" + .AddChar "C", 3 + .AddAlphanumeric "C" + .AddDuplicate "C" + .AddRequired "D" + .AddVarchar "D", 80 + .AddVarchar "E", 80 + .AddVarchar "F", 80 + .AddCheck01 "G" + .AddRequired "H" + .AddNumber "H", 6 + .AddRequired "I" + .AddNumber "I", 6 + End With - Dim checkResult As Boolean: checkResult = False + Call engine.ValidateRow(ws, rowNum, lastDataRow) - ' C column check - checkResult = CheckRequired(ws, rowNum, 3, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckChar(ws, rowNum, 3, 3, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckAlphanumeric(ws, rowNum, 3, 3, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckDuplicate(ws, rowNum, 3, errorCol) - If checkResult = False Then Exit Sub - - ' D column check - checkResult = CheckRequired(ws, rowNum, 4, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckVarcharOver(ws, rowNum, 4, 80, errorCol) - If checkResult = False Then Exit Sub - - ' E column check - checkResult = CheckVarcharOver(ws, rowNum, 5, 80, errorCol) - If checkResult = False Then Exit Sub - - ' F column check - checkResult = CheckVarcharOver(ws, rowNum, 6, 80, errorCol) - If checkResult = False Then Exit Sub - - ' G column check - checkResult = Check01(ws, rowNum, 7, errorCol) - If checkResult = False Then Exit Sub - - ' H column check number - checkResult = CheckRequired(ws, rowNum, 8, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckNumber(ws, rowNum, 8, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckNumberOver(ws, rowNum, 8, 6, errorCol) - If checkResult = False Then Exit Sub - - ' I column check number - checkResult = CheckRequired(ws, rowNum, 9, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckNumber(ws, rowNum, 9, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckNumberOver(ws, rowNum, 9, 6, errorCol) - If checkResult = False Then Exit Sub - - ws.Cells(rowNum, errorCol).ClearContents Exit Sub ErrHandler: - lastErrorMsg = Err.Description + SetLastErrorMsg Err.Description End Sub \ No newline at end of file diff --git a/src/sh/tuk/sheet/Z1.cls b/src/sh/tuk/sheet/Z1.cls index ad4138b..31fd947 100644 --- a/src/sh/tuk/sheet/Z1.cls +++ b/src/sh/tuk/sheet/Z1.cls @@ -62,63 +62,26 @@ 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 engine As ValidationRuleEngine: Set engine = New ValidationRuleEngine + With engine + .AddRequired "C" + .AddChar "C", 3 + .AddAlphanumeric "C" + .AddDuplicate "C" + .AddRequired "D" + .AddVarchar "D", 80 + .AddVarchar "E", 80 + .AddVarchar "F", 80 + .AddVarchar "G", 80 + .AddCheck01 "H" + .AddVarchar "I", 80 + End With - ' clear C~I columns background color - Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol)) - clearRange.Interior.Color = vbWhite - - Dim checkResult As Boolean: checkResult = False + Call engine.ValidateRow(ws, rowNum, lastDataRow) - ' C column check - checkResult = CheckRequired(ws, rowNum, 3, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckChar(ws, rowNum, 3, 3, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckAlphanumeric(ws, rowNum, 3, 3, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckDuplicate(ws, rowNum, 3, errorCol) - If checkResult = False Then Exit Sub - - ' D column check - checkResult = CheckRequired(ws, rowNum, 4, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckVarcharOver(ws, rowNum, 4, 80, errorCol) - If checkResult = False Then Exit Sub - - ' E column check - checkResult = CheckVarcharOver(ws, rowNum, 5, 80, errorCol) - If checkResult = False Then Exit Sub - - ' F column check - checkResult = CheckVarcharOver(ws, rowNum, 6, 80, errorCol) - If checkResult = False Then Exit Sub - - ' G column check - checkResult = CheckVarcharOver(ws, rowNum, 7, 80, errorCol) - If checkResult = False Then Exit Sub - - ' H column check - checkResult = Check01(ws, rowNum, 8, errorCol) - If checkResult = False Then Exit Sub - - ' I column check - checkResult = CheckVarcharOver(ws, rowNum, 9, 80, errorCol) - If checkResult = False Then Exit Sub - - ws.Cells(rowNum, errorCol).ClearContents Exit Sub ErrHandler: - lastErrorMsg = Err.Description + SetLastErrorMsg Err.Description End Sub \ No newline at end of file diff --git a/src/sh/tuk/sheet/Z2.cls b/src/sh/tuk/sheet/Z2.cls index 1e4716c..2037be6 100644 --- a/src/sh/tuk/sheet/Z2.cls +++ b/src/sh/tuk/sheet/Z2.cls @@ -59,58 +59,27 @@ Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) 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") - - ' clear C~G columns background color - Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol)) - clearRange.Interior.Color = vbWhite + Dim engine As ValidationRuleEngine: Set engine = New ValidationRuleEngine + With engine + .AddRequired "C" + .AddChar "C", 1 + .AddAlphanumeric "C" + .AddDuplicate "C" + .AddRequired "D" + .AddVarchar "D", 80 + .AddVarchar "E", 80 + .AddVarchar "F", 80 + .AddCheck01 "G" + End With - Dim checkResult As Boolean: checkResult = False + Call engine.ValidateRow(ws, rowNum, lastDataRow) - ' C column check - checkResult = CheckRequired(ws, rowNum, 3, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckChar(ws, rowNum, 3, 1, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckAlphanumeric(ws, rowNum, 3, 1, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckDuplicate(ws, rowNum, 3, errorCol) - If checkResult = False Then Exit Sub - - ' D column check - checkResult = CheckRequired(ws, rowNum, 4, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckVarcharOver(ws, rowNum, 4, 80, errorCol) - If checkResult = False Then Exit Sub - - ' E column check - checkResult = CheckVarcharOver(ws, rowNum, 5, 80, errorCol) - If checkResult = False Then Exit Sub - - ' F column check - checkResult = CheckVarcharOver(ws, rowNum, 6, 80, errorCol) - If checkResult = False Then Exit Sub - - ' G column check - checkResult = Check01(ws, rowNum, 7, errorCol) - If checkResult = False Then Exit Sub - - ws.Cells(rowNum, errorCol).ClearContents Exit Sub ErrHandler: - lastErrorMsg = Err.Description + SetLastErrorMsg Err.Description End Sub \ No newline at end of file diff --git a/src/sh/tuk/sheet/Z3.cls b/src/sh/tuk/sheet/Z3.cls index 1b2bcb9..9c94407 100644 --- a/src/sh/tuk/sheet/Z3.cls +++ b/src/sh/tuk/sheet/Z3.cls @@ -59,62 +59,28 @@ Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) 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") - - ' clear C~H columns background color - Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol)) - clearRange.Interior.Color = vbWhite - - Dim checkResult As Boolean: checkResult = False + Dim engine As ValidationRuleEngine: Set engine = New ValidationRuleEngine + With engine + .AddRequired "C" + .AddChar "C", 2 + .AddAlphanumeric "C" + .AddDuplicate "C" + .AddRequired "D" + .AddVarchar "D", 80 + .AddVarchar "E", 80 + .AddVarchar "F", 80 + .AddCheck01 "G" + .AddVarchar "H", 80 + End With - ' C column check - checkResult = CheckRequired(ws, rowNum, 3, errorCol) - If checkResult = False Then Exit Sub + Call engine.ValidateRow(ws, rowNum, lastDataRow) - checkResult = CheckChar(ws, rowNum, 3, 2, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckAlphanumeric(ws, rowNum, 3, 2, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckDuplicate(ws, rowNum, 3, errorCol) - If checkResult = False Then Exit Sub - - ' D column check - checkResult = CheckRequired(ws, rowNum, 4, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckVarcharOver(ws, rowNum, 4, 80, errorCol) - If checkResult = False Then Exit Sub - - ' E column check - checkResult = CheckVarcharOver(ws, rowNum, 5, 80, errorCol) - If checkResult = False Then Exit Sub - - ' F column check - checkResult = CheckVarcharOver(ws, rowNum, 6, 80, errorCol) - If checkResult = False Then Exit Sub - - ' G column check - checkResult = Check01(ws, rowNum, 7, errorCol) - If checkResult = False Then Exit Sub - - ' H column check - checkResult = CheckVarcharOver(ws, rowNum, 8, 80, errorCol) - If checkResult = False Then Exit Sub - - ws.Cells(rowNum, errorCol).ClearContents Exit Sub ErrHandler: - lastErrorMsg = Err.Description + SetLastErrorMsg Err.Description End Sub \ No newline at end of file diff --git a/src/sh/tuk/sheet/Z4.cls b/src/sh/tuk/sheet/Z4.cls index 7c607ff..75cedea 100644 --- a/src/sh/tuk/sheet/Z4.cls +++ b/src/sh/tuk/sheet/Z4.cls @@ -63,58 +63,25 @@ 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 engine As ValidationRuleEngine: Set engine = New ValidationRuleEngine + With engine + .AddRequired "C" + .AddChar "C", 6 + .AddAlphanumeric "C" + .AddDuplicate "C" + .AddRequired "D" + .AddVarchar "D", 80 + .AddVarchar "E", 80 + .AddRequired "F" + .AddVarchar "F", 80 + .AddVarchar "G", 80 + .AddCheck01 "H" + End With - Dim startCol As String: startCol = sheetConf("StartCol") - Dim endCol As String: endCol = sheetConf("EndCol") - Dim errorCol As String: errorCol = sheetConf("ErrorCol") + Call engine.ValidateRow(ws, rowNum, lastDataRow) - ' clear C~H columns background color - Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol)) - clearRange.Interior.Color = vbWhite - - Dim checkResult As Boolean: checkResult = False - - ' C column check - checkResult = CheckRequired(ws, rowNum, 3, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckChar(ws, rowNum, 3, 6, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckAlphanumeric(ws, rowNum, 3, 6, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckDuplicate(ws, rowNum, 3, errorCol) - If checkResult = False Then Exit Sub - - ' D column check - checkResult = CheckRequired(ws, rowNum, 4, errorCol) - If checkResult = False Then Exit Sub - - checkResult = CheckVarcharOver(ws, rowNum, 4, 80, errorCol) - If checkResult = False Then Exit Sub - - ' E column check - checkResult = CheckVarcharOver(ws, rowNum, 5, 80, errorCol) - If checkResult = False Then Exit Sub - - ' F column check - checkResult = CheckVarcharOver(ws, rowNum, 6, 80, errorCol) - If checkResult = False Then Exit Sub - - ' G column check - checkResult = CheckVarcharOver(ws, rowNum, 7, 80, errorCol) - If checkResult = False Then Exit Sub - - ' H column check - checkResult = Check01(ws, rowNum, 8, errorCol) - If checkResult = False Then Exit Sub - - ws.Cells(rowNum, errorCol).ClearContents Exit Sub ErrHandler: - lastErrorMsg = Err.Description + SetLastErrorMsg Err.Description End Sub \ No newline at end of file diff --git a/src/sh/tuk/validation/ValidationResult.cls b/src/sh/tuk/validation/ValidationResult.cls new file mode 100644 index 0000000..e82c939 --- /dev/null +++ b/src/sh/tuk/validation/ValidationResult.cls @@ -0,0 +1,31 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ValidationResult" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public Passed As Boolean +Public ErrorCode As String +Public ErrorCol As Long +Public ErrorRow As Long +Public Extra As String ' extra info per rule type (e.g. duplicate value for ERR_DUPLICATE) + +Private Sub Class_Initialize() + Passed = True +End Sub + +' ============================================================ +' Mark this result as a failure. +' ============================================================ +Public Sub SetFail(errorCode As String, errorCol As Long, errorRow As Long, Optional extra As String = "") + Passed = False + Me.ErrorCode = errorCode + Me.ErrorCol = errorCol + Me.ErrorRow = errorRow + Me.Extra = extra +End Sub diff --git a/src/sh/tuk/validation/ValidationRule.cls b/src/sh/tuk/validation/ValidationRule.cls new file mode 100644 index 0000000..cb53af2 --- /dev/null +++ b/src/sh/tuk/validation/ValidationRule.cls @@ -0,0 +1,161 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ValidationRule" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +' --- Properties --- +' RuleKind (ValRule_*), ColIndex, ColLetter, CacheName, MinVal, MaxVal, +' CharLen, VarcharLen, NumberDigits, NumberDec, StartRow +Public RuleKind As Long +Public ColIndex As Long +Public ColLetter As String +Public CacheName As String +Public MinVal As Double +Public MaxVal As Double +Public CharLen As Long +Public VarcharLen As Long +Public NumberDigits As Long +Public NumberDec As Long +Public StartRow As Long + +' --- Error Codes --- +Private Const ERR_REQUIRED As String = "E002" +Private Const ERR_INVALID As String = "E001" +Private Const ERR_RANGE As String = "E004" +Private Const ERR_NOT_EXIST As String = "E004" +Private Const ERR_DUPLICATE As String = "E010" +Private Const ERR_CHARLEN As String = "E006" +Private Const ERR_VARLEN As String = "E007" +Private Const ERR_CHECK01 As String = "E008" +Private Const ERR_NUMDIGITS As String = "E014" + +' ============================================================ +' Execute this rule against a worksheet row. +' Returns a ValidationResult object. +' ============================================================ +Public Function ValidateRow(ws As Worksheet, rowNum As Long, Optional lastDataRow As Long = 0) As ValidationResult + Dim result As ValidationResult: Set result = New ValidationResult + + Select Case RuleKind + + Case ValRule_Required + If Trim(ws.Cells(rowNum, ColIndex).Value & "") = "" Then + result.SetFail ERR_REQUIRED, ColIndex, rowNum + End If + + Case ValRule_Date + Dim dateVal As String: dateVal = Trim(ws.Cells(rowNum, ColIndex).Value & "") + If dateVal <> "" Then + If Len(dateVal) <> 10 Or Mid(dateVal, 5, 1) <> "-" Or Mid(dateVal, 8, 1) <> "-" Then + result.SetFail ERR_INVALID, ColIndex, rowNum + End If + End If + + Case ValRule_Number + Dim numVal As String: numVal = Trim(ws.Cells(rowNum, ColIndex).Value & "") + If numVal <> "" Then + If Not IsNumeric(numVal) Then + result.SetFail ERR_INVALID, ColIndex, rowNum + ElseIf NumberDigits > 0 Or NumberDec > 0 Then + Dim dotPos As Long: dotPos = InStr(numVal, ".") + Dim intPart As String + Dim decPart As String + If dotPos > 0 Then + intPart = Left(numVal, dotPos - 1) + decPart = Mid(numVal, dotPos + 1) + Else + intPart = numVal + decPart = "" + End If + If Left(intPart, 1) = "-" Then intPart = Mid(intPart, 2) + If Len(intPart) = 0 Then + result.SetFail ERR_NUMDIGITS, ColIndex, rowNum, "Number(" & NumberDigits & ", " & NumberDec & ")" + ElseIf Len(intPart) > NumberDigits - NumberDec Then + result.SetFail ERR_NUMDIGITS, ColIndex, rowNum, "Number(" & NumberDigits & ", " & NumberDec & ")" + ElseIf NumberDec > 0 And Len(decPart) > NumberDec Then + result.SetFail ERR_NUMDIGITS, ColIndex, rowNum, "Number(" & NumberDigits & ", " & NumberDec & ")" + End If + End If + End If + + Case ValRule_CodeSelect + Dim codeVal As String: codeVal = Trim(ws.Cells(rowNum, ColIndex).Value & "") + If codeVal <> "" Then + Dim cache As Object: Set cache = GetCache(CacheName) + Dim code As String: code = GetCode(codeVal) + If Not cache.Exists(code) Then + result.SetFail ERR_NOT_EXIST, ColIndex, rowNum + End If + End If + + Case ValRule_Range + Dim rangeVal As String: rangeVal = Trim(ws.Cells(rowNum, ColIndex).Value & "") + If rangeVal <> "" Then + If Not IsNumeric(rangeVal) Then + result.SetFail ERR_INVALID, ColIndex, rowNum + ElseIf CDbl(rangeVal) < MinVal Or CDbl(rangeVal) > MaxVal Then + result.SetFail ERR_RANGE, ColIndex, rowNum + End If + End If + + Case ValRule_Duplicate + Dim dupVal As String: dupVal = Trim(ws.Cells(rowNum, ColIndex).Value & "") + If dupVal <> "" Then + Dim upperRow As Long: upperRow = rowNum - 1 + Dim firstRow As Long: firstRow = IIf(StartRow > 0, StartRow, 7) + Dim i As Long + For i = firstRow To upperRow + If Trim(ws.Cells(i, ColIndex).Value & "") = dupVal Then + result.SetFail ERR_DUPLICATE, ColIndex, rowNum, dupVal + Exit For + End If + Next i + End If + + Case ValRule_Char + Dim charVal As String: charVal = Trim(ws.Cells(rowNum, ColIndex).Value & "") + If charVal <> "" And Len(charVal) <> CharLen Then + result.SetFail ERR_CHARLEN, ColIndex, rowNum, CStr(CharLen) + End If + + Case ValRule_Varchar + Dim varcharVal As String: varcharVal = Trim(ws.Cells(rowNum, ColIndex).Value & "") + If varcharVal <> "" And Len(varcharVal) > VarcharLen Then + result.SetFail ERR_VARLEN, ColIndex, rowNum, CStr(VarcharLen) + End If + + Case ValRule_Check01 + Dim chk01Val As String: chk01Val = Trim(ws.Cells(rowNum, ColIndex).Value & "") + If chk01Val <> "" Then + If Len(chk01Val) <> 1 Or (chk01Val <> "0" And chk01Val <> "1") Then + result.SetFail ERR_CHECK01, ColIndex, rowNum + End If + End If + + Case ValRule_Alphanumeric + Dim alphaVal As String: alphaVal = Trim(ws.Cells(rowNum, ColIndex).Value & "") + If alphaVal <> "" Then + Dim j As Long + Dim ch2 As String + For j = 1 To Len(alphaVal) + ch2 = Mid(alphaVal, j, 1) + If Not ((ch2 >= "0" And ch2 <= "9") Or (ch2 >= "A" And ch2 <= "Z") Or (ch2 >= "a" And ch2 <= "z")) Then + result.SetFail ERR_INVALID, ColIndex, rowNum + Exit For + End If + Next j + End If + + Case ValRule_Custom + ' Reserved for future extension + + End Select + + Set ValidateRow = result +End Function \ No newline at end of file diff --git a/src/sh/tuk/validation/ValidationRuleEngine.cls b/src/sh/tuk/validation/ValidationRuleEngine.cls new file mode 100644 index 0000000..366da13 --- /dev/null +++ b/src/sh/tuk/validation/ValidationRuleEngine.cls @@ -0,0 +1,180 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ValidationRuleEngine" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private pRules As VBA.Collection + +Private Sub Class_Initialize() + Set pRules = New VBA.Collection +End Sub + +' ============================================================ +' Add a Required rule directly (convenience method). +' ============================================================ +Public Sub AddRequired(ByVal colIndex As String) + Dim r As ValidationRule: Set r = New ValidationRule + r.RuleKind = ValRule_Required + r.ColIndex = IIf(IsNumeric(colIndex), colIndex, ColNum(CStr(colIndex))) + pRules.Add r + Set r = Nothing +End Sub + +Public Sub AddDate(colIndex As Variant) + Dim r As ValidationRule: Set r = New ValidationRule + r.RuleKind = ValRule_Date + r.ColIndex = IIf(IsNumeric(colIndex), colIndex, ColNum(CStr(colIndex))) + pRules.Add r + Set r = Nothing +End Sub + +Public Sub AddNumber(colIndex As Variant, Optional totalDigits As Long = 0, Optional decimalDigits As Long = 0) + Dim r As ValidationRule: Set r = New ValidationRule + r.RuleKind = ValRule_Number + r.ColIndex = IIf(IsNumeric(colIndex), colIndex, ColNum(CStr(colIndex))) + If totalDigits > 0 Then r.NumberDigits = totalDigits + If decimalDigits > 0 Then r.NumberDec = decimalDigits + pRules.Add r + Set r = Nothing +End Sub + +Public Sub AddCodeSelect(colIndex As Variant, cacheName As String) + Dim r As ValidationRule: Set r = New ValidationRule + r.RuleKind = ValRule_CodeSelect + r.ColIndex = IIf(IsNumeric(colIndex), colIndex, ColNum(CStr(colIndex))) + r.CacheName = cacheName + pRules.Add r + Set r = Nothing +End Sub + +Public Sub AddRange(colIndex As Variant, minVal As Double, maxVal As Double) + Dim r As ValidationRule: Set r = New ValidationRule + r.RuleKind = ValRule_Range + r.ColIndex = IIf(IsNumeric(colIndex), colIndex, ColNum(CStr(colIndex))) + r.MinVal = minVal + r.MaxVal = maxVal + pRules.Add r + Set r = Nothing +End Sub + +Public Sub AddDuplicate(colIndex As Variant, Optional firstRow As Long = 0) + Dim r As ValidationRule: Set r = New ValidationRule + r.RuleKind = ValRule_Duplicate + r.ColIndex = IIf(IsNumeric(colIndex), colIndex, ColNum(CStr(colIndex))) + If firstRow > 0 Then r.StartRow = firstRow + pRules.Add r + Set r = Nothing +End Sub + +Public Sub AddChar(colIndex As Variant, charLen As Long) + Dim r As ValidationRule: Set r = New ValidationRule + r.RuleKind = ValRule_Char + r.ColIndex = IIf(IsNumeric(colIndex), colIndex, ColNum(CStr(colIndex))) + r.CharLen = charLen + pRules.Add r + Set r = Nothing +End Sub + +Public Sub AddVarchar(colIndex As Variant, maxLen As Long) + Dim r As ValidationRule: Set r = New ValidationRule + r.RuleKind = ValRule_Varchar + r.ColIndex = IIf(IsNumeric(colIndex), colIndex, ColNum(CStr(colIndex))) + r.VarcharLen = maxLen + pRules.Add r + Set r = Nothing +End Sub + +Public Sub AddCheck01(colIndex As Variant) + Dim r As ValidationRule: Set r = New ValidationRule + r.RuleKind = ValRule_Check01 + r.ColIndex = IIf(IsNumeric(colIndex), colIndex, ColNum(CStr(colIndex))) + pRules.Add r + Set r = Nothing +End Sub + + + +Public Sub AddAlphanumeric(colIndex As Variant) + Dim r As ValidationRule: Set r = New ValidationRule + r.RuleKind = ValRule_Alphanumeric + r.ColIndex = IIf(IsNumeric(colIndex), colIndex, ColNum(CStr(colIndex))) + pRules.Add r + Set r = Nothing +End Sub + +' ============================================================ +' Run all rules against the given row. +' Clears row background at start, outputs error on failure. +' lastDataRow is required when Duplicate rules are registered. +' Returns Nothing if all rules pass. +' ============================================================ +Public Function ValidateRow(ws As Worksheet, rowNum As Long, Optional lastDataRow As Long = 0) As ValidationResult + ' Clear row background + Call ClearRowBg(ws, rowNum) + + Dim r As ValidationRule + Dim result As ValidationResult + + For Each r In pRules + Set result = r.ValidateRow(ws, rowNum, lastDataRow) + If Not result.Passed Then + Call OutputError(ws, rowNum, result) + Set ValidateRow = result + Exit Function + End If + Next r + + ' All passed + Set ValidateRow = New ValidationResult +End Function + +' ============================================================ +' Number of rules registered. +' ============================================================ +Public Property Get RuleCount() As Long + RuleCount = pRules.Count +End Property + +' ============================================================ +' Clear background color for the given row. +' Uses the colIndex of each registered rule to build the range. +' Call this before running ValidateRow. +' ============================================================ +Public Sub ClearRowBg(ws As Worksheet, rowNum As Long) + Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig() + Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName) + Dim errorCol As Long: errorCol = ColNum(CStr(sheetConf("ErrorCol"))) + Dim endCol As Long: endCol = ColNum(CStr(sheetConf("EndCol"))) + + Dim clearRange As Range + Set clearRange = ws.Range(ws.Cells(rowNum, errorCol), ws.Cells(rowNum, endCol)) + clearRange.Interior.Color = vbWhite + ws.Cells(rowNum, errorCol).ClearContents +End Sub + +' ============================================================ +' Write error message and highlight the failed cell. +' Resolves errorCol from sheet config internally. +' Call this after ValidateRow when result.Passed = False. +' ============================================================ +Public Sub OutputError(ws As Worksheet, rowNum As Long, result As ValidationResult) + Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig() + Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName) + Dim errorCol As Long: errorCol = ColNum(CStr(sheetConf("ErrorCol"))) + + If result.Passed Then + If Not StartsWith(ws.Cells(rowNum, errorCol).Value, "W") Then + ws.Cells(rowNum, errorCol).ClearContents + End If + Else + Dim cellAddr As String: cellAddr = ColLetter(result.ErrorCol) + ws.Cells(rowNum, errorCol).Value = GetErrorMsg(result.ErrorCode, cellAddr & CStr(result.ErrorRow), result.Extra) + ws.Cells(rowNum, result.ErrorCol).Interior.Color = RGB(255, 0, 0) + End If +End Sub \ No newline at end of file diff --git a/通勤手当テンプレート20260528.xlsm b/通勤手当テンプレート20260528.xlsm new file mode 100644 index 0000000..077ba72 Binary files /dev/null and b/通勤手当テンプレート20260528.xlsm differ