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

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

Browse Source
This commit is contained in:
guanxiangwei
2026-06-01 10:51:12 +09:00
parent 35598420c5
commit 8d72584611
4 changed files with 244 additions and 245 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/sh/tuk/module/Common_Global_Cache.bas
+2 -2
View File
@@ -344,13 +344,13 @@ Private Sub RefreshSheetDict()
' C1
Set sheetConf = CreateObject("Scripting.Dictionary")
sheetConf("StartCol") = "C"
sheetConf("EndCol") = "BC"
sheetConf("EndCol") = "BG"
sheetConf("ErrorCol") = "B"
sheetConf("StartRow") = 8
sheetConf("HeaderRow") = 6
sheetConf("CSV_Encoding") = "shift_jis"
sheetConf("HasHeader") = True
sheetConf("ExpectedColumnCount") = 41
sheetConf("ExpectedColumnCount") = 45
sheetConf("HeaderColumns") = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "W", "X", "Y", "Z", "AA", "AE", "AF", "AG", "AH", "AI", "AM", "AN", "AO", "AP", "AQ", "AU", "AV", "AW", "AX", "AY", "AZ", "BA", "BB", "BC", "BD", "BE", "BF", "BG")
sheetConf("AlwaysQuote") = False
sheetConf("FilterRow") = 7
src/sh/tuk/sheet/C1.cls
+236 -243
View File
@@ -56,7 +56,7 @@ Private Function KUKAN_START_DAY_COLS() As Variant
End Function
Private Function DATE_COLS() As Variant
DATE_COLS = Array(4, 5, 6, 26, 34, 42, 50, 56, 59) ' D, E, F, Z, AH, AP, AX, BC, BF
DATE_COLS = Array(4, 5, 6, 26, 34, 42, 50, 55, 58) ' D, E, F, Z, AH, AP, AX, BC, BF
End Function
Private Function NUMBER_COLS() As Variant
@@ -89,15 +89,7 @@ Private Sub Worksheet_Change(ByVal Target As Range)
With Me
Set watchArea = Union( _
.Columns("C"), _
.Columns("D"), _
.Columns("E"), _
.Columns("F"), _
.Columns("G"), _
.Columns("I"), _
.Columns("S:X"), _
.Columns("AA:AF"), _
.Columns("AI:AN"), _
.Columns("AQ:AV") _
.Columns("D:BG") _
)
End With
Dim intersectRng As Range: Set intersectRng = Application.Intersect(Target, watchArea)
@@ -278,6 +270,240 @@ Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
End If
End Sub
' Validation logic
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
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 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)
' I/J address validation
Dim o1Cache As Object: Set o1Cache = GetCache(CACHE_O1)
Dim ColI As String: ColI = "I"
Dim ColJ As String: ColJ = "J"
Dim address1 As String: address1 = Trim(ws.Cells(rowNum, ColI).Value)
Dim address2 As String: address2 = Trim(ws.Cells(rowNum, ColJ).Value)
If address1 = "" Then
If address2 <> "" Then
errorCell.Value = ColJ & " column is invalid"
ws.Range(ColJ & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Else
Dim empNo As String: empNo = Trim(ws.Cells(rowNum, 3).Value)
If Not o1Cache.Exists(empNo) Then
errorCell.Value = ColI & " column is invalid"
ws.Range(ColI & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Dim innerDict As Object: Set innerDict = o1Cache(empNo)
If Not innerDict.Exists(address1) Then
errorCell.Value = ColI & " column is invalid"
ws.Range(ColI & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Dim addr2Dict As Object: Set addr2Dict = innerDict(address1)
If Not addr2Dict.Exists(address2) Then
errorCell.Value = ColJ & " column is invalid"
ws.Range(ColJ & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
End If
' K column (readonly)
Dim ColK As String: ColK = "K"
If Trim(ws.Cells(rowNum, ColK).Value) <> "" Then
errorCell.Value = ColK & " column can not be input"
ws.Range(ColK & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
' KUKAN block (kept as-is)
Dim m1Cache As Object: Set m1Cache = GetCache("M1")
Dim m2Cache As Object: Set m2Cache = GetCache("M2")
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)
Dim kukanIdx As Long
For kukanIdx = LBound(KUKAN_CODE_COLS) To UBound(KUKAN_CODE_COLS)
Dim kukanCol As Long: kukanCol = KUKAN_CODE_COLS(kukanIdx)
Dim kukanCode As String: kukanCode = Trim(ws.Cells(rowNum, kukanCol).Value)
Dim kukanLetter As String: kukanLetter = Split(ws.Cells(1, kukanCol).Address, "$")(1)
If kukanCode <> "" Then
If Not m1Cache.Exists(kukanCode) Then
errorCell.Value = kukanLetter & " column does not exist"
ws.Range(kukanLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Dim ticketCol As Long: ticketCol = KUKAN_TICKET_COLS(kukanIdx)
Dim code2Col As Long: code2Col = KUKAN_CODE2_COLS(kukanIdx)
Dim teikiCol As Long: teikiCol = KUKAN_TEIKI_COLS(kukanIdx)
Dim ticketVal As String: ticketVal = GetCode(Trim(ws.Cells(rowNum, ticketCol).Value))
Dim code2Val As String: code2Val = GetCode(Trim(ws.Cells(rowNum, code2Col).Value))
Dim ticketLetter As String: ticketLetter = Split(ws.Cells(1, ticketCol).Address, "$")(1)
Dim code2Letter As String: code2Letter = Split(ws.Cells(1, code2Col).Address, "$")(1)
If ticketVal = "" Then
errorCell.Value = ticketLetter & " column must be input"
ws.Range(ticketLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
If ticketVal = "0" Then
If code2Val <> "" Then
errorCell.Value = code2Letter & " column is invalid"
ws.Range(code2Letter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Else
Dim kanshuDict As Object
If m2Cache.Exists(kukanCode) Then
Set kanshuDict = m2Cache(kukanCode)
If Not kanshuDict.Exists(ticketVal) Then
errorCell.Value = ticketLetter & " column is invalid"
ws.Range(ticketLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
If code2Val = "" Then
errorCell.Value = code2Letter & " column should be input"
ws.Range(code2Letter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
Else
Dim codeDict As Object: Set codeDict = kanshuDict(ticketVal)
If Not codeDict.Exists(code2Val) Then
errorCell.Value = code2Letter & " column is invalid"
ws.Range(code2Letter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
Else
Dim teikiValue As String: teikiValue = Trim(ws.Cells(rowNum, teikiCol).Value)
If ticketVal = "1" And teikiValue = "" Then
Dim teikiLetter As String: teikiLetter = ColLetter(teikiCol)
errorCell.Value = teikiLetter & " column is required"
ws.Range(teikiLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
End If
End If
End If
End If
Else
Dim colGroup As Variant
For Each colGroup In kukanCols
Dim checkCol As Long: checkCol = colGroup(kukanIdx)
Dim checkVal As String: checkVal = Trim(ws.Cells(rowNum, checkCol).Value)
If checkVal <> "" Then
Dim checkLetter As String: checkLetter = Split(ws.Cells(1, checkCol).Address, "$")(1)
errorCell.Value = checkLetter & " column requires " & kukanLetter & " column"
ws.Range(checkLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Next colGroup
End If
Next kukanIdx
' KUKAN_CODE_COLS duplicate check
Dim kukanCodes As Object: Set kukanCodes = CreateObject("Scripting.Dictionary")
For kukanIdx = LBound(KUKAN_CODE_COLS) To UBound(KUKAN_CODE_COLS)
kukanCol = KUKAN_CODE_COLS(kukanIdx)
kukanCode = Trim(ws.Cells(rowNum, kukanCol).Value)
If kukanCode <> "" Then
If kukanCodes.Exists(kukanCode) Then
kukanLetter = Split(ws.Cells(1, kukanCol).Address, "$")(1)
errorCell.Value = GetErrorMsg("E003", kukanLetter & rowNum)
ws.Range(kukanLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
Else
kukanCodes.Add kukanCode, True
End If
End If
Next kukanIdx
' H/BB/BC (always runs, independent of special cases)
Dim linkCellValue As String: linkCellValue = ws.Cells(3, "H").Value
Dim ColBF As String: ColBF = "BF"
Dim ColBG As String: ColBG = "BG"
Dim valBF As String: valBF = Trim(ws.Cells(rowNum, ColBF).Value)
Dim valBG As String: valBG = Trim(ws.Cells(rowNum, ColBG).Value)
If linkCellValue = "1" Then
If valBF <> "" Then
errorCell.Value = GetErrorMsg("E005", ColBF & rowNum)
ws.Range(ColBF & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
If valBG <> "" Then
errorCell.Value = GetErrorMsg("E005", ColBG & rowNum)
ws.Range(ColBG & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
ElseIf linkCellValue = "2" Then
If valBF = "" Then
errorCell.Value = GetErrorMsg("E002", ColBF & rowNum)
ws.Range(ColBF & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
If valBG = "" Then
errorCell.Value = GetErrorMsg("E002", ColBG & rowNum)
ws.Range(ColBG & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
End If
Exit Sub
ErrHandler:
SetLastErrorMsg Err.Description
End Sub
Private Sub Refresh(ws As Worksheet, ByVal startRow As Long, ByVal lastDataRow As Long)
Dim z1Cache As Object: Set z1Cache = GetCache(CACHE_Z1)
@@ -772,239 +998,6 @@ Private Sub ClearRowData(ByVal rowNum As Long)
Me.Range(Me.Cells(rowNum, startCol), Me.Cells(rowNum, endCol)).Interior.Color = vbWhite
End Sub
' Validation logic
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
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 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)
' I/J address validation
Dim o1Cache As Object: Set o1Cache = GetCache(CACHE_O1)
Dim ColI As String: ColI = "I"
Dim ColJ As String: ColJ = "J"
Dim address1 As String: address1 = Trim(ws.Cells(rowNum, ColI).Value)
Dim address2 As String: address2 = Trim(ws.Cells(rowNum, ColJ).Value)
If address1 = "" Then
If address2 <> "" Then
errorCell.Value = ColJ & " column is invalid"
ws.Range(ColJ & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Else
Dim empNo As String: empNo = Trim(ws.Cells(rowNum, 3).Value)
If Not o1Cache.Exists(empNo) Then
errorCell.Value = ColI & " column is invalid"
ws.Range(ColI & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Dim innerDict As Object: Set innerDict = o1Cache(empNo)
If Not innerDict.Exists(address1) Then
errorCell.Value = ColI & " column is invalid"
ws.Range(ColI & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Dim addr2Dict As Object: Set addr2Dict = innerDict(address1)
If Not addr2Dict.Exists(address2) Then
errorCell.Value = ColJ & " column is invalid"
ws.Range(ColJ & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
End If
' K column (readonly)
Dim ColK As String: ColK = "K"
If Trim(ws.Cells(rowNum, ColK).Value) <> "" Then
errorCell.Value = ColK & " column can not be input"
ws.Range(ColK & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
' KUKAN block (kept as-is)
Dim m1Cache As Object: Set m1Cache = GetCache("M1")
Dim m2Cache As Object: Set m2Cache = GetCache("M2")
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)
Dim kukanIdx As Long
For kukanIdx = LBound(KUKAN_CODE_COLS) To UBound(KUKAN_CODE_COLS)
Dim kukanCol As Long: kukanCol = KUKAN_CODE_COLS(kukanIdx)
Dim kukanCode As String: kukanCode = Trim(ws.Cells(rowNum, kukanCol).Value)
Dim kukanLetter As String: kukanLetter = Split(ws.Cells(1, kukanCol).Address, "$")(1)
If kukanCode <> "" Then
If Not m1Cache.Exists(kukanCode) Then
errorCell.Value = kukanLetter & " column does not exist"
ws.Range(kukanLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Dim ticketCol As Long: ticketCol = KUKAN_TICKET_COLS(kukanIdx)
Dim code2Col As Long: code2Col = KUKAN_CODE2_COLS(kukanIdx)
Dim teikiCol As Long: teikiCol = KUKAN_TEIKI_COLS(kukanIdx)
Dim ticketVal As String: ticketVal = GetCode(Trim(ws.Cells(rowNum, ticketCol).Value))
Dim code2Val As String: code2Val = GetCode(Trim(ws.Cells(rowNum, code2Col).Value))
Dim ticketLetter As String: ticketLetter = Split(ws.Cells(1, ticketCol).Address, "$")(1)
Dim code2Letter As String: code2Letter = Split(ws.Cells(1, code2Col).Address, "$")(1)
If ticketVal = "" Then
errorCell.Value = ticketLetter & " column must be input"
ws.Range(ticketLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
If ticketVal = "0" Then
If code2Val <> "" Then
errorCell.Value = code2Letter & " column is invalid"
ws.Range(code2Letter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Else
Dim kanshuDict As Object
If m2Cache.Exists(kukanCode) Then
Set kanshuDict = m2Cache(kukanCode)
If Not kanshuDict.Exists(ticketVal) Then
errorCell.Value = ticketLetter & " column is invalid"
ws.Range(ticketLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
If code2Val = "" Then
errorCell.Value = code2Letter & " column should be input"
ws.Range(code2Letter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
Else
Dim codeDict As Object: Set codeDict = kanshuDict(ticketVal)
If Not codeDict.Exists(code2Val) Then
errorCell.Value = code2Letter & " column is invalid"
ws.Range(code2Letter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
Else
Dim teikiValue As String: teikiValue = Trim(ws.Cells(rowNum, teikiCol).Value)
If ticketVal = "1" And teikiValue = "" Then
Dim teikiLetter As String: teikiLetter = ColLetter(teikiCol)
errorCell.Value = teikiLetter & " column is required"
ws.Range(teikiLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
End If
End If
End If
End If
Else
Dim colGroup As Variant
For Each colGroup In kukanCols
Dim checkCol As Long: checkCol = colGroup(kukanIdx)
Dim checkVal As String: checkVal = Trim(ws.Cells(rowNum, checkCol).Value)
If checkVal <> "" Then
Dim checkLetter As String: checkLetter = Split(ws.Cells(1, checkCol).Address, "$")(1)
errorCell.Value = checkLetter & " column requires " & kukanLetter & " column"
ws.Range(checkLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Next colGroup
End If
Next kukanIdx
' KUKAN_CODE_COLS duplicate check
Dim kukanCodes As Object: Set kukanCodes = CreateObject("Scripting.Dictionary")
For kukanIdx = LBound(KUKAN_CODE_COLS) To UBound(KUKAN_CODE_COLS)
kukanCol = KUKAN_CODE_COLS(kukanIdx)
kukanCode = Trim(ws.Cells(rowNum, kukanCol).Value)
If kukanCode <> "" Then
If kukanCodes.Exists(kukanCode) Then
kukanLetter = Split(ws.Cells(1, kukanCol).Address, "$")(1)
errorCell.Value = GetErrorMsg("E003", kukanLetter & rowNum)
ws.Range(kukanLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
Else
kukanCodes.Add kukanCode, True
End If
End If
Next kukanIdx
' H/BB/BC (always runs, independent of special cases)
Dim linkCellValue As String: linkCellValue = ws.Cells(3, "H").Value
Dim ColBF As String: ColBF = "BF"
Dim ColBG As String: ColBG = "BG"
Dim valBF As String: valBF = Trim(ws.Cells(rowNum, ColBF).Value)
Dim valBG As String: valBG = Trim(ws.Cells(rowNum, ColBG).Value)
If linkCellValue = "1" Then
If valBF <> "" Then
errorCell.Value = GetErrorMsg("E005", ColBF & rowNum)
ws.Range(ColBF & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
If valBG <> "" Then
errorCell.Value = GetErrorMsg("E005", ColBG & rowNum)
ws.Range(ColBG & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
ElseIf linkCellValue = "2" Then
If valBF = "" Then
errorCell.Value = GetErrorMsg("E002", ColBF & rowNum)
ws.Range(ColBF & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
If valBG = "" Then
errorCell.Value = GetErrorMsg("E002", ColBG & rowNum)
ws.Range(ColBG & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
End If
Exit Sub
ErrHandler:
SetLastErrorMsg Err.Description
End Sub
' Create teiki dropdown based on M2 cache
Private Sub CreateTeikiDropdown(ByVal row As Long, ByVal idx As Long)
' Get kukanCode from KUKAN_CODE_COLS
src/sh/tuk/validation/ValidationRule.cls
+6
View File
@@ -43,6 +43,12 @@ Public Function ValidateRow(ws As Worksheet, rowNum As Long, Optional lastDataRo
If dateVal <> "" Then
If Len(dateVal) <> 10 Or Mid(dateVal, 5, 1) <> "-" Or Mid(dateVal, 8, 1) <> "-" Then
result.SetFail ERR_INVALID, ColIndex, rowNum
ElseIf Not IsNumeric(Left(dateVal, 4)) Then
result.SetFail ERR_INVALID, ColIndex, rowNum
ElseIf Not IsNumeric(Mid(dateVal, 6, 2)) Then
result.SetFail ERR_INVALID, ColIndex, rowNum
ElseIf Not IsNumeric(Right(dateVal, 2)) Then
result.SetFail ERR_INVALID, ColIndex, rowNum
End If
End If