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

通勤認定エクセルツール対応16

Browse Source
This commit is contained in:
guanxiangwei
2026-05-30 18:39:37 +09:00
parent 8611cb4f1e
commit 47c7d95266
7 changed files with 283 additions and 474 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -433,154 +433,3 @@ End Function
Function ColNum(colLetter As String) As Long Function ColNum(colLetter As String) As Long
ColNum = Range(colLetter & "1").Column ColNum = Range(colLetter & "1").Column
End Function 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
Dim letter As String: letter = ColLetter(colNum)
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E002", letter & rowNum)
ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
CheckRequired = False
Exit Function
End If
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
Dim letter As String: letter = ColLetter(colNum)
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E006", letter & rowNum, charLength)
ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
CheckChar = False
Exit Function
End If
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)
Dim i As Long
Dim ch As String
For i = 1 To charLength
ch = Mid(checkValue, i, 1)
If Not ((ch >= "0" And ch <= "9") Or (ch >= "A" And ch <= "Z") Or (ch >= "a" And ch <= "z")) Then
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E005", letter & rowNum)
ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
CheckAlphanumeric = False
Exit Function
End If
Next i
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
Dim letter As String: letter = ColLetter(colNum)
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E007", letter & rowNum)
ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
CheckVarcharOver = False
Exit Function
End If
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
Dim letter As String: letter = ColLetter(colNum)
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E014", letter & rowNum, numberLength)
ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
CheckNumberOver = False
Exit Function
End If
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)
If checkValue <> "" Then
If Len(checkValue) <> 1 Then
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E001", letter & rowNum)
ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
Check01 = False
Exit Function
End If
If checkValue <> "0" And checkValue <> "1" Then
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E008", letter & rowNum)
ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
Check01 = False
Exit Function
End If
End If
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)
If checkValue <> "" Then
If Len(checkValue) <> 1 Then
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E001", letter & rowNum)
ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
Check12 = False
Exit Function
End If
If checkValue <> "1" And checkValue <> "2" Then
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E009", letter & rowNum)
ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
Check12 = False
Exit Function
End If
End If
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)
Dim i As Long
For i = 7 To rowNum - 1
If Trim(ws.Cells(i, colNum).Value) = checkValue Then
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E010", letter & rowNum, checkValue)
ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
CheckDuplicate = False
Exit Function
End If
Next i
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)
If checkValue = "" Then
CheckNumber = True
Exit Function
End If
If Not IsNumeric(checkValue) Then
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E011", letter & rowNum)
ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
CheckNumber = False
Exit Function
End If
CheckNumber = True
End Function

13
src/sh/tuk/module/ValidationRuleEnums.bas
View File

@@ -14,4 +14,15 @@ Public Const ValRule_Char As Long = 6
Public Const ValRule_Varchar As Long = 7 Public Const ValRule_Varchar As Long = 7
Public Const ValRule_Check01 As Long = 8 Public Const ValRule_Check01 As Long = 8
Public Const ValRule_Alphanumeric As Long = 9 Public Const ValRule_Alphanumeric As Long = 9
Public Const ValRule_Custom As Long = 11 Public Const ValRule_Custom As Long = 11
' --- Error Codes ---
Public Const ERR_REQUIRED As String = "E002"
Public Const ERR_INVALID As String = "E001"
Public Const ERR_RANGE As String = "E004"
Public Const ERR_NOT_EXIST As String = "E004"
Public Const ERR_DUPLICATE As String = "E010"
Public Const ERR_CHARLEN As String = "E006"
Public Const ERR_VARLEN As String = "E007"
Public Const ERR_CHECK01 As String = "E008"
Public Const ERR_NUMDIGITS As String = "E014"

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

@@ -775,198 +775,162 @@ End Sub
' Validation logic ' Validation logic
Public 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 On Error GoTo ErrHandler
Dim engine As ValidationRuleEngine: Set engine = New ValidationRuleEngine
With engine
' Required columns
.AddRequired "C"
.AddRequired "D"
.AddRequired "E"
.AddRequired "F"
.AddRequired "G"
.AddRequired "L"
.AddRequired "M"
.AddRequired "N"
.AddRequired "BA"
' Date columns
.AddDate "D"
.AddDate "E"
.AddDate "F"
.AddDate "Z"
.AddDate "AH"
.AddDate "AP"
.AddDate "AX"
.AddDate "BC"
.AddDate "BF"
' Number columns (numeric check only, no digit limit)
.AddNumber "L", 2
.AddNumber "P", 4, 1
.AddNumber "Q", 6
.AddNumber "R", 6
' G column o3Cache
.AddCodeSelect "G", CACHE_O3
' M column oufukuList
.AddCodeSelect "M", "oufukuList"
' N column koutaiList
.AddCodeSelect "N", "koutaiList"
End With
Dim result As ValidationResult: Set result = engine.ValidateRow(ws, rowNum, lastDataRow)
If result.ErrorCode <> "" Then Exit Sub
' === Special cases (cross-column / cross-cache) ===
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig() Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName) 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 errorCol As String: errorCol = sheetConf("ErrorCol")
Dim errorCell As Range: Set errorCell = ws.Cells(rowNum, errorCol)
Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol)) ' I/J address validation
clearRange.Interior.Color = vbWhite
' Required columns: C-G, K-N, AW
Dim requiredCols As Variant
requiredCols = Array("C", "D", "E", "F", "G", "L", "M", "N", "BA")
Dim col As Variant
For Each col In requiredCols
If Trim(Me.Range(col & rowNum).Value & "") = "" Then
Me.Cells(rowNum, errorCol).Value = GetErrorMsg("E002", col & rowNum)
Me.Range(col & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Next col
' validate date
Dim colIndex As Variant
For Each colIndex In DATE_COLS()
Dim cellDate As String: cellDate = Trim(Me.Cells(rowNum, colIndex).Value)
If cellDate <> "" Then
' Require full YYYY-MM-DD format (output of FormatDateInput)
If Len(cellDate) <> 10 Or Mid(cellDate, 5, 1) <> "-" Or Mid(cellDate, 8, 1) <> "-" Then
Dim letter As String: letter = Split(Me.Cells(1, colIndex).Address, "$")(1)
Me.Cells(rowNum, errorCol).Value = GetErrorMsg("E001", letter & rowNum)
Me.Range(letter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
End If
Next colIndex
' validate number
For Each col In NUMBER_COLS()
Dim cellNumber As String: cellNumber = Trim(Me.Cells(rowNum, col).Value)
If cellNumber <> "" And Not IsNumeric(cellNumber) Then
Me.Cells(rowNum, errorCol).Value = GetErrorMsg("E001", col & rowNum)
Me.Range(col & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Next col
' validate CodeSelect
' G column [todoke Cde]
Dim ColG As String: ColG = "G"
Dim o3Cache As Object: Set o3Cache = GetCache(CACHE_O3)
Dim todokeCde As String: todokeCde = GetCode(Trim(Me.Cells(rowNum, ColG).Value))
If Not o3Cache.Exists(todokeCde) Then
Me.Cells(rowNum, errorCol).Value = GetErrorMsg("E001", ColG & rowNum)
Me.Range(ColG & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
' I column [address1 J column address2]
Dim o1Cache As Object: Set o1Cache = GetCache(CACHE_O1) Dim o1Cache As Object: Set o1Cache = GetCache(CACHE_O1)
Dim ColI As String: ColI = "I" Dim ColI As String: ColI = "I"
Dim ColJ As String: ColJ = "J" Dim ColJ As String: ColJ = "J"
Dim address1 As String: address1 = Trim(Me.Cells(rowNum, ColI).Value) Dim address1 As String: address1 = Trim(ws.Cells(rowNum, ColI).Value)
Dim address2 As String: address2 = Trim(Me.Cells(rowNum, ColJ).Value) Dim address2 As String: address2 = Trim(ws.Cells(rowNum, ColJ).Value)
If address1 = "" Then If address1 = "" Then
If address2 <> "" Then If address2 <> "" Then
Me.Cells(rowNum, errorCol).Value = ColJ & " column is invalid" errorCell.Value = ColJ & " column is invalid"
Me.Range(ColJ & rowNum).Interior.Color = RGB(255, 0, 0) ws.Range(ColJ & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
End If End If
Else Else
Dim empNo As String: empNo = Trim(Me.Cells(rowNum, 3).Value) Dim empNo As String: empNo = Trim(ws.Cells(rowNum, 3).Value)
If Not o1Cache.Exists(empNo) Then If Not o1Cache.Exists(empNo) Then
Me.Cells(rowNum, errorCol).Value = ColI & " column is invalid" errorCell.Value = ColI & " column is invalid"
Me.Range(ColI & rowNum).Interior.Color = RGB(255, 0, 0) ws.Range(ColI & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
End If End If
Dim innerDict As Object: Set innerDict = o1Cache(empNo)
Dim innerDict As Object: Set innerDict = o1Cache(empNo) If Not innerDict.Exists(address1) Then
If Not innerDict.Exists(address1) Then errorCell.Value = ColI & " column is invalid"
Me.Cells(rowNum, errorCol).Value = ColI & " column is invalid" ws.Range(ColI & rowNum).Interior.Color = RGB(255, 0, 0)
Me.Range(ColI & rowNum).Interior.Color = RGB(255, 0, 0) Exit Sub
Exit Sub End If
End If Dim addr2Dict As Object: Set addr2Dict = innerDict(address1)
Dim addr2Dict As Object: Set addr2Dict = innerDict(address1) If Not addr2Dict.Exists(address2) Then
If Not addr2Dict.Exists(address2) Then errorCell.Value = ColJ & " column is invalid"
Me.Cells(rowNum, errorCol).Value = ColJ & " column is invalid" ws.Range(ColJ & rowNum).Interior.Color = RGB(255, 0, 0)
Me.Range(ColJ & rowNum).Interior.Color = RGB(255, 0, 0) Exit Sub
Exit Sub End If
End If
End If End If
' K column ' K column (readonly)
Dim ColK As String: ColK = "K" Dim ColK As String: ColK = "K"
If Trim(Me.Cells(rowNum, ColK).Value) <> "" Then If Trim(ws.Cells(rowNum, ColK).Value) <> "" Then
Me.Cells(rowNum, errorCol).Value = ColK & " column can not be input" errorCell.Value = ColK & " column can not be input"
Me.Range(ColK & rowNum).Interior.Color = RGB(255, 0, 0) ws.Range(ColK & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
End If End If
' validate CodeSelect ' KUKAN block (kept as-is)
' M column [oufuku]
Dim ColM As String: ColM = "M"
Dim oufukuList As Object: Set oufukuList = GetCache("oufukuList")
Dim oufukuCde As String: oufukuCde = GetCode(Trim(Me.Cells(rowNum, ColM).Value))
If Not oufukuList.Exists(oufukuCde) Then
Me.Cells(rowNum, errorCol).Value = GetErrorMsg("E001", ColM & rowNum)
Me.Range(ColM & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
' validate CodeSelect
' N column [koutai]
Dim ColN As String: ColN = "N"
Dim koutaiList As Object: Set koutaiList = GetCache("koutaiList")
Dim koutaiCde As String: koutaiCde = GetCode(Trim(Me.Cells(rowNum, ColN).Value))
If Not koutaiList.Exists(koutaiCde) Then
Me.Cells(rowNum, errorCol).Value = ColN & " column is invalid"
Me.Range(ColN & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
' validate KUKAN_CODE_COLS (S, Z, AG, AN) and related columns
Dim m1Cache As Object: Set m1Cache = GetCache("M1") Dim m1Cache As Object: Set m1Cache = GetCache("M1")
Dim m2Cache As Object: Set m2Cache = GetCache("M2") Dim m2Cache As Object: Set m2Cache = GetCache("M2")
Dim kukanCols As Variant Dim kukanCols As Variant
kukanCols = Array(KUKAN_TRANSPORT_COLS, KUKAN_STATION_COLS, KUKAN_ARRIVAL_COLS, KUKAN_TICKET_COLS, KUKAN_CODE2_COLS, KUKAN_START_DAY_COLS) kukanCols = Array(KUKAN_TRANSPORT_COLS, KUKAN_STATION_COLS, KUKAN_ARRIVAL_COLS, KUKAN_TICKET_COLS, KUKAN_CODE2_COLS, KUKAN_START_DAY_COLS)
Dim kukanIdx As Long Dim kukanIdx As Long
For kukanIdx = LBound(KUKAN_CODE_COLS) To UBound(KUKAN_CODE_COLS) For kukanIdx = LBound(KUKAN_CODE_COLS) To UBound(KUKAN_CODE_COLS)
Dim kukanCol As Long: kukanCol = KUKAN_CODE_COLS(kukanIdx) Dim kukanCol As Long: kukanCol = KUKAN_CODE_COLS(kukanIdx)
Dim kukanCode As String: kukanCode = Trim(Me.Cells(rowNum, kukanCol).Value) Dim kukanCode As String: kukanCode = Trim(ws.Cells(rowNum, kukanCol).Value)
Dim kukanLetter As String: kukanLetter = Split(Me.Cells(1, kukanCol).Address, "$")(1) Dim kukanLetter As String: kukanLetter = Split(ws.Cells(1, kukanCol).Address, "$")(1)
If kukanCode <> "" Then If kukanCode <> "" Then
' KUKAN_CODE has value, check if exists in m1Cache
If Not m1Cache.Exists(kukanCode) Then If Not m1Cache.Exists(kukanCode) Then
Me.Cells(rowNum, errorCol).Value = kukanLetter & " column does not exist" errorCell.Value = kukanLetter & " column does not exist"
Me.Range(kukanLetter & rowNum).Interior.Color = RGB(255, 0, 0) ws.Range(kukanLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
End If End If
' Validate KUKAN_TICKET_COLS and KUKAN_CODE2_COLS
Dim ticketCol As Long: ticketCol = KUKAN_TICKET_COLS(kukanIdx) Dim ticketCol As Long: ticketCol = KUKAN_TICKET_COLS(kukanIdx)
Dim code2Col As Long: code2Col = KUKAN_CODE2_COLS(kukanIdx) Dim code2Col As Long: code2Col = KUKAN_CODE2_COLS(kukanIdx)
Dim teikiCol As Long: teikiCol = KUKAN_TEIKI_COLS(kukanIdx) Dim teikiCol As Long: teikiCol = KUKAN_TEIKI_COLS(kukanIdx)
Dim ticketVal As String: ticketVal = GetCode(Trim(Me.Cells(rowNum, ticketCol).Value)) Dim ticketVal As String: ticketVal = GetCode(Trim(ws.Cells(rowNum, ticketCol).Value))
Dim code2Val As String: code2Val = GetCode(Trim(Me.Cells(rowNum, code2Col).Value)) Dim code2Val As String: code2Val = GetCode(Trim(ws.Cells(rowNum, code2Col).Value))
Dim ticketLetter As String: ticketLetter = Split(Me.Cells(1, ticketCol).Address, "$")(1) Dim ticketLetter As String: ticketLetter = Split(ws.Cells(1, ticketCol).Address, "$")(1)
Dim code2Letter As String: code2Letter = Split(Me.Cells(1, code2Col).Address, "$")(1) Dim code2Letter As String: code2Letter = Split(ws.Cells(1, code2Col).Address, "$")(1)
If ticketVal = "" Then If ticketVal = "" Then
Me.Cells(rowNum, errorCol).Value = ticketLetter & " column must be input" errorCell.Value = ticketLetter & " column must be input"
Me.Range(ticketLetter & rowNum).Interior.Color = RGB(255, 0, 0) ws.Range(ticketLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
End If End If
If ticketVal = "0" Then If ticketVal = "0" Then
If code2Val <> "" Then If code2Val <> "" Then
Me.Cells(rowNum, errorCol).Value = code2Letter & " column is invalid" errorCell.Value = code2Letter & " column is invalid"
Me.Range(code2Letter & rowNum).Interior.Color = RGB(255, 0, 0) ws.Range(code2Letter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
End If End If
Else Else
' Check if ticket exists in m2Cache for this kukanCode
Dim kanshuDict As Object Dim kanshuDict As Object
If m2Cache.Exists(kukanCode) Then If m2Cache.Exists(kukanCode) Then
Set kanshuDict = m2Cache(kukanCode) Set kanshuDict = m2Cache(kukanCode)
If Not kanshuDict.Exists(ticketVal) Then If Not kanshuDict.Exists(ticketVal) Then
Me.Cells(rowNum, errorCol).Value = ticketLetter & " column is invalid" errorCell.Value = ticketLetter & " column is invalid"
Me.Range(ticketLetter & rowNum).Interior.Color = RGB(255, 0, 0) ws.Range(ticketLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
End If End If
' If code2 also has value, verify it exists in m2Cache
If code2Val = "" Then If code2Val = "" Then
Me.Cells(rowNum, errorCol).Value = code2Letter & " column should be input" errorCell.Value = code2Letter & " column should be input"
Me.Range(code2Letter & rowNum).Interior.Color = RGB(255, 0, 0) ws.Range(code2Letter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
Else Else
Dim codeDict As Object: Set codeDict = kanshuDict(ticketVal) Dim codeDict As Object: Set codeDict = kanshuDict(ticketVal)
If Not codeDict.Exists(code2Val) Then If Not codeDict.Exists(code2Val) Then
Me.Cells(rowNum, errorCol).Value = code2Letter & " column is invalid" errorCell.Value = code2Letter & " column is invalid"
Me.Range(code2Letter & rowNum).Interior.Color = RGB(255, 0, 0) ws.Range(code2Letter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
Else Else
Dim teikiValue As String: teikiValue = Trim(Me.Cells(rowNum, teikiCol).Value) Dim teikiValue As String: teikiValue = Trim(ws.Cells(rowNum, teikiCol).Value)
If ticketVal = "1" And teikiValue = "" Then If ticketVal = "1" And teikiValue = "" Then
Dim teikiLetter As String: teikiLetter = ColLetter(teikiCol) Dim teikiLetter As String: teikiLetter = ColLetter(teikiCol)
Me.Cells(rowNum, errorCol).Value = teikiLetter & " column is required" errorCell.Value = teikiLetter & " column is required"
Me.Range(teikiLetter & rowNum).Interior.Color = RGB(255, 0, 0) ws.Range(teikiLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
End If End If
End If End If
@@ -974,31 +938,30 @@ Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
End If End If
End If End If
Else Else
' KUKAN_CODE is empty, check that related columns are also empty
Dim colGroup As Variant Dim colGroup As Variant
For Each colGroup In kukanCols For Each colGroup In kukanCols
Dim checkCol As Long: checkCol = colGroup(kukanIdx) Dim checkCol As Long: checkCol = colGroup(kukanIdx)
Dim checkVal As String: checkVal = Trim(Me.Cells(rowNum, checkCol).Value) Dim checkVal As String: checkVal = Trim(ws.Cells(rowNum, checkCol).Value)
If checkVal <> "" Then If checkVal <> "" Then
Dim checkLetter As String: checkLetter = Split(Me.Cells(1, checkCol).Address, "$")(1) Dim checkLetter As String: checkLetter = Split(ws.Cells(1, checkCol).Address, "$")(1)
Me.Cells(rowNum, errorCol).Value = checkLetter & " column requires " & kukanLetter & " column" errorCell.Value = checkLetter & " column requires " & kukanLetter & " column"
Me.Range(checkLetter & rowNum).Interior.Color = RGB(255, 0, 0) ws.Range(checkLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
End If End If
Next colGroup Next colGroup
End If End If
Next kukanIdx Next kukanIdx
' Validate KUKAN_CODE_COLS for duplicates (non-empty only) ' KUKAN_CODE_COLS duplicate check
Dim kukanCodes As Object: Set kukanCodes = CreateObject("Scripting.Dictionary") Dim kukanCodes As Object: Set kukanCodes = CreateObject("Scripting.Dictionary")
For kukanIdx = LBound(KUKAN_CODE_COLS) To UBound(KUKAN_CODE_COLS) For kukanIdx = LBound(KUKAN_CODE_COLS) To UBound(KUKAN_CODE_COLS)
kukanCol = KUKAN_CODE_COLS(kukanIdx) kukanCol = KUKAN_CODE_COLS(kukanIdx)
kukanCode = Trim(Me.Cells(rowNum, kukanCol).Value) kukanCode = Trim(ws.Cells(rowNum, kukanCol).Value)
If kukanCode <> "" Then If kukanCode <> "" Then
If kukanCodes.Exists(kukanCode) Then If kukanCodes.Exists(kukanCode) Then
kukanLetter = Split(Me.Cells(1, kukanCol).Address, "$")(1) kukanLetter = Split(ws.Cells(1, kukanCol).Address, "$")(1)
Me.Cells(rowNum, errorCol).Value = GetErrorMsg("E003", kukanLetter & rowNum) errorCell.Value = GetErrorMsg("E003", kukanLetter & rowNum)
Me.Range(kukanLetter & rowNum).Interior.Color = RGB(255, 0, 0) ws.Range(kukanLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
Else Else
kukanCodes.Add kukanCode, True kukanCodes.Add kukanCode, True
@@ -1006,40 +969,36 @@ Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
End If End If
Next kukanIdx Next kukanIdx
' Validate H, BB, BC columns ' H/BB/BC (always runs, independent of special cases)
Dim linkCellValue As String: linkCellValue = Me.Cells(3, "H").Value Dim linkCellValue As String: linkCellValue = ws.Cells(3, "H").Value
Dim ColBF As String: ColBF = "BF" Dim ColBF As String: ColBF = "BF"
Dim ColBG As String: ColBG = "BG" Dim ColBG As String: ColBG = "BG"
Dim valBF As String: valBF = Trim(Me.Cells(rowNum, ColBF).Value) Dim valBF As String: valBF = Trim(ws.Cells(rowNum, ColBF).Value)
Dim valBG As String: valBG = Trim(Me.Cells(rowNum, ColBG).Value) Dim valBG As String: valBG = Trim(ws.Cells(rowNum, ColBG).Value)
If linkCellValue = "1" Then If linkCellValue = "1" Then
' If code = "1", BB and BC must be empty
If valBF <> "" Then If valBF <> "" Then
Me.Cells(rowNum, errorCol).Value = GetErrorMsg("E005", ColBF & rowNum) errorCell.Value = GetErrorMsg("E005", ColBF & rowNum)
Me.Range(ColBF & rowNum).Interior.Color = RGB(255, 0, 0) ws.Range(ColBF & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
End If End If
If valBG <> "" Then If valBG <> "" Then
Me.Cells(rowNum, errorCol).Value = GetErrorMsg("E005", ColBG & rowNum) errorCell.Value = GetErrorMsg("E005", ColBG & rowNum)
Me.Range(ColBG & rowNum).Interior.Color = RGB(255, 0, 0) ws.Range(ColBG & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
End If End If
ElseIf linkCellValue = "2" Then ElseIf linkCellValue = "2" Then
' If code = "2", BB and BC must have value
If valBF = "" Then If valBF = "" Then
Me.Cells(rowNum, errorCol).Value = GetErrorMsg("E002", ColBF & rowNum) errorCell.Value = GetErrorMsg("E002", ColBF & rowNum)
Me.Range(ColBF & rowNum).Interior.Color = RGB(255, 0, 0) ws.Range(ColBF & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
End If End If
If valBG = "" Then If valBG = "" Then
Me.Cells(rowNum, errorCol).Value = GetErrorMsg("E002", ColBG & rowNum) errorCell.Value = GetErrorMsg("E002", ColBG & rowNum)
Me.Range(ColBG & rowNum).Interior.Color = RGB(255, 0, 0) ws.Range(ColBG & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
End If End If
End If End If
Me.Cells(rowNum, errorCol).ClearContents
Exit Sub Exit Sub
ErrHandler: ErrHandler:

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

@@ -150,50 +150,48 @@ Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
Dim result As ValidationResult: Set result = engine.ValidateRow(ws, rowNum, lastDataRow) Dim result As ValidationResult: Set result = engine.ValidateRow(ws, rowNum, lastDataRow)
If result.ErrorCode <> "" Then Exit Sub
' === Special cases (cross-column / cross-cache) === ' === Special cases (cross-column / cross-cache) ===
If result.ErrorCode = "" Then Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig() Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName) Dim errorCol As String: errorCol = sheetConf("ErrorCol")
Dim errorCol As String: errorCol = sheetConf("ErrorCol") Dim errorCell As Range: Set errorCell = ws.Cells(rowNum, errorCol)
Dim errorCell As Range: Set errorCell = ws.Cells(rowNum, errorCol)
' E: must equal CACHE_Z1(D) value ' E: must equal CACHE_Z1(D) value
Dim z1Cache As Object: Set z1Cache = GetCache(CACHE_Z1) Dim z1Cache As Object: Set z1Cache = GetCache(CACHE_Z1)
Dim dValue As String: dValue = Trim(ws.Range("D" & rowNum).Value) Dim dValue As String: dValue = Trim(ws.Range("D" & rowNum).Value)
Dim valArray As Variant: valArray = z1Cache(dValue) Dim valArray As Variant: valArray = z1Cache(dValue)
Dim expectedE As String: expectedE = Trim(CStr(valArray(0))) Dim expectedE As String: expectedE = Trim(CStr(valArray(0)))
Dim eValue As String: eValue = Trim(ws.Range("E" & rowNum).Value) Dim eValue As String: eValue = Trim(ws.Range("E" & rowNum).Value)
If eValue <> expectedE Then If eValue <> expectedE Then
errorCell.Value = GetErrorMsg(ERR_NOT_EXIST, "E" & CStr(rowNum)) errorCell.Value = GetErrorMsg(ERR_NOT_EXIST, "E" & CStr(rowNum))
ws.Range("E" & rowNum).Interior.Color = RGB(255, 0, 0) ws.Range("E" & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub 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 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
Exit Sub Exit Sub
ErrHandler: ErrHandler:
SetLastErrorMsg Err.Description SetLastErrorMsg Err.Description
End Sub End Sub

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

@@ -112,7 +112,6 @@ Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
Dim engine As ValidationRuleEngine: Set engine = New ValidationRuleEngine Dim engine As ValidationRuleEngine: Set engine = New ValidationRuleEngine
With engine With engine
.AddRequired "C" .AddRequired "C"
.AddDuplicate "C"
.AddCodeSelect "C", CACHE_M1 .AddCodeSelect "C", CACHE_M1
.AddRequired "I" .AddRequired "I"
.AddRequired "J" .AddRequired "J"
@@ -131,117 +130,121 @@ Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
Dim result As ValidationResult: Set result = engine.ValidateRow(ws, rowNum, lastDataRow) Dim result As ValidationResult: Set result = engine.ValidateRow(ws, rowNum, lastDataRow)
' === Special cases (cross-cache / cross-column) === ' === Special cases (cross-cache / cross-column) ===
If result.ErrorCode = "" Then If result.ErrorCode <> "" Then Exit Sub
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)
' J: must exist in T1/T2/T3 cache (determined by I column) Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
Dim kenshuKbn As String: kenshuKbn = Trim(ws.Range("I" & rowNum).Value) Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
Dim cache As Object Dim errorCol As String: errorCol = sheetConf("ErrorCol")
Select Case kenshuKbn Dim errorCell As Range: Set errorCell = ws.Cells(rowNum, errorCol)
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
Dim code As String: code = Trim(ws.Range("J" & rowNum).Value) ' J: must exist in T1/T2/T3 cache (determined by I column)
If Not cache.Exists(code) Then Dim kenshuKbn As String: kenshuKbn = Trim(ws.Range("I" & rowNum).Value)
errorCell.Value = GetErrorMsg(ERR_NOT_EXIST, "J" & rowNum) Dim cache As Object
ws.Range("J" & rowNum).Interior.Color = RGB(255, 0, 0) 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 Exit Sub
End If End Select
' kenshuKbn-specific: equaledCols, requiredCols, emptyCols Dim kukanCode As String: kukanCode = Trim(ws.Range("C" & rowNum).Value)
Dim equaledCols As Variant Dim code As String: code = Trim(ws.Range("J" & rowNum).Value)
Dim requiredCols As Variant If Not cache.Exists(code) Then
Dim emptyCols As Variant errorCell.Value = GetErrorMsg(ERR_NOT_EXIST, "J" & rowNum)
If kenshuKbn = "1" Then ws.Range("J" & rowNum).Interior.Color = RGB(255, 0, 0)
equaledCols = Array("K") Exit Sub
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
' 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 End If
' validate passed, clear error cell and setup backcolor ' kenshuKbn-specific: equaledCols, requiredCols, emptyCols
errorCell.ClearContents Dim equaledCols As Variant
Call ChangeBackColor(rowNum) Dim requiredCols As Variant
Exit Sub Dim emptyCols As Variant
If kenshuKbn = "1" Then
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
' 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
If rowNum < 9 Then
Call ChangeBackColor(rowNum)
Exit Sub
End If
For otherRow = 8 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 = kukanCode And otherValueI = kenshuKbn And otherValueJ = code And otherValueN = sikyuKikan Then
hasError = True
End If
Else
If otherValueC = kukanCode 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
Call ChangeBackColor(rowNum)
Exit Sub
ErrHandler: ErrHandler:
SetLastErrorMsg Err.Description SetLastErrorMsg Err.Description
End Sub End Sub

2
src/sh/tuk/validation/ValidationResult.cls
View File

@@ -22,7 +22,7 @@ End Sub
' ============================================================ ' ============================================================
' Mark this result as a failure. ' Mark this result as a failure.
' ============================================================ ' ============================================================
Public Sub SetFail(errorCode As String, errorCol As Long, errorRow As Long, Optional extra As String = "") Public Sub SetFail(ByVal errorCode As String, errorCol As Long, errorRow As Long, Optional extra As String = "")
Passed = False Passed = False
Me.ErrorCode = errorCode Me.ErrorCode = errorCode
Me.ErrorCol = errorCol Me.ErrorCol = errorCol

11
src/sh/tuk/validation/ValidationRule.cls
View File

@@ -24,17 +24,6 @@ Public NumberDigits As Long
Public NumberDec As Long Public NumberDec As Long
Public StartRow 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. ' Execute this rule against a worksheet row.
' Returns a ValidationResult object. ' Returns a ValidationResult object.