diff --git a/src/sh/tuk/module/Common_Button.bas b/src/sh/tuk/module/Common_Button.bas index f0527e5..33d0991 100644 --- a/src/sh/tuk/module/Common_Button.bas +++ b/src/sh/tuk/module/Common_Button.bas @@ -137,9 +137,9 @@ Private Sub DO_CSV_Import(ws As Excel.Worksheet) End If ' === Step 4: Clear all data rows before import === + Call ClearDataRows(ws) Application.ScreenUpdating = False Application.EnableEvents = False - Call ClearDataRows(ws) ' === Step 5: Write CSV data to worksheet === Dim colLetters As Variant: colLetters = cfg("HeaderColumns") @@ -194,11 +194,16 @@ Private Sub Do_Validation(ws As Excel.Worksheet) Application.Run "M1.ValidateWarn", ws, lastDataRow End If - Do_Fit ws + GoTo FinallyExit Exit Sub ErrorHandler: HandleError "Do_Validation" + GoTo FinallyExit + +FinallyExit: + Do_Fit ws + ClearFormatsBelowLastDataRow ws End Sub ' ============================================================ @@ -258,9 +263,11 @@ Private Sub DO_CSV_Export(ws As Excel.Worksheet) Dim colLetters As Variant: colLetters = sheetConf("HeaderColumns") Dim r As Long + Dim colIndex As Long For r = startRow To lastDataRow For colIdx = 0 To expectedColumnCount - 1 - outputArr(dataRow, colIdx + 1) = CleanCSVField(ws.Cells(r, Columns(colLetters(colIdx))).Column).Value) + colIndex = Columns(colLetters(colIdx)).Column + outputArr(dataRow, colIdx + 1) = CleanCSVField(ws.Cells(r, colIndex).Value) Next colIdx dataRow = dataRow + 1 Next r diff --git a/src/sh/tuk/module/Common_Functions.bas b/src/sh/tuk/module/Common_Functions.bas index fbb30b3..2f7616e 100644 --- a/src/sh/tuk/module/Common_Functions.bas +++ b/src/sh/tuk/module/Common_Functions.bas @@ -45,7 +45,7 @@ ErrorHandler: Err.Raise ERR_CONFIG_INVALID, "GetCSVHeader", "Invalid column letter in HeaderColumns: '" & colLetters(i) & "'" End Function -' +' Clean CSV field: add quote prefix for formula-like values Function CleanCSVField(ByVal inputStr As String) As String Dim s As String s = Trim(inputStr) @@ -62,10 +62,12 @@ Function CleanCSVField(ByVal inputStr As String) As String CleanCSVField = s End Function +' Get last data row in specified column Function GetLastDataRow(ByVal ws As Worksheet, ByVal columnNum As Long) As Long GetLastDataRow = ws.Cells(ws.Rows.Count, columnNum).End(xlUp).Row End Function +' Check if array contains value Function Contains(ByVal arr As Variant, ByVal value As String) As Boolean Dim i As Long For i = 0 To UBound(arr) @@ -184,7 +186,7 @@ ErrHandler: Err.Raise Err.Number, Err.Source, Err.Description End Function -' obtain +' Get last data row in specified column Function GetLastDataRowInRange(ws As Worksheet) As Long Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig() @@ -218,6 +220,7 @@ InvalidColumn: Err.Raise ERR_CONFIG_INVALID, "GetLastDataRowInRange", "Invalid column letter for sheet: " & ws.CodeName End Function +'Clear single row data and format Function ClearDataRow(ByVal ws As Worksheet, ByVal startCol As Long, ByVal endCol As Long, ByVal rowRow As Long, Optional ByVal errorCol As Long = 2) If rowRow >= 7 Then Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowRow, startCol), ws.Cells(rowRow, endCol)) @@ -227,8 +230,9 @@ Function ClearDataRow(ByVal ws As Worksheet, ByVal startCol As Long, ByVal endCo End If End Function +'Clear all data rows from startRow to lastDataRow Sub ClearDataRows(ByVal ws As Worksheet) - ' + ' Clear data and format from startRow to lastDataRow Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig() ' If Not sheetConfDict.Exists(ws.CodeName) Then @@ -241,10 +245,9 @@ Sub ClearDataRows(ByVal ws As Worksheet) Dim startCol As String: startCol = sheetConf("StartCol") Dim endCol As String: endCol = sheetConf("EndCol") Dim errorCol As String: errorCol = sheetConf("ErrorCol") - ' + + Application.EnableEvents = False Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws) - - ' If lastDataRow >= startRow Then Dim clearRange As Range Set clearRange = ws.Range(ws.Cells(startRow, ws.Range(startCol & "1").Column), ws.Cells(lastDataRow, ws.Range(endCol & "1").Column)) @@ -258,9 +261,52 @@ Sub ClearDataRows(ByVal ws As Worksheet) clearErrorRange.Interior.Color = vbWhite End If End If + + ' Clear formats below lastDataRow (including dropdowns) + Application.EnableEvents = True + Call ClearFormatsBelowLastDataRow(ws) End Sub -' Format: code:value (no space around colon) +'Clear formats below lastDataRow +Sub ClearFormatsBelowLastDataRow(ws As Worksheet) + On Error GoTo ErrorHandler + Dim lastRow As Long: lastRow = GetLastDataRowInRange(ws) + + Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig() + Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName) + + Dim startCol As Long, endCol As Long + startCol = ws.Range(sheetConf("ErrorCol") & "1").Column + endCol = ws.Range(sheetConf("EndCol") & "1").Column + + If lastRow >= ws.Rows.Count Then Exit Sub + + Dim clearRange As Range + Set clearRange = ws.Range( _ + ws.Cells(lastRow + 1, startCol), _ + ws.Cells(ws.Rows.Count, endCol) _ + ) + + Application.EnableEvents = False + clearRange.ClearContents + clearRange.Interior.Color = vbWhite + clearRange.Validation.Delete + Application.EnableEvents = True + +ErrorHandler: + Application.EnableEvents = True +End Sub + +' Check if text starts with prefix +Function StartsWith(text As String, prefix As String) As Boolean + If Len(text) < Len(prefix) Then + StartsWith = False + Else + StartsWith = (Left(text, Len(prefix)) = prefix) + End If +End Function + +' Make select format: code:value Function MakeSelect(ByVal code As String, ByVal value As String) As String MakeSelect = Trim(code) & ":" & Trim(value) End Function @@ -316,16 +362,16 @@ Public Function FormatDateInput(ByVal inputStr As String) As String End If End Function +'Check header edit protection Function CheckHeaderEdit(ByVal ws As Worksheet, ByVal Target As Range) As Boolean Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig() Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName) - Dim headerRow As Long: headerRow = sheetConf("HeaderRow") Dim filterRow As Long: filterRow = sheetConf("FilterRow") ' Check header row (headerRow) cannot be edited Dim r As Long For r = Target.Row To Target.Row + Target.Rows.Count - 1 - If r = headerRow Or r = filterRow Then + If r = 1 Or r = filterRow Then Application.EnableEvents = False MsgBox "Header or type definition row cannot be edited.", vbExclamation Application.Undo @@ -355,6 +401,7 @@ Function CheckHeaderEdit(ByVal ws As Worksheet, ByVal Target As Range) As Boolea CheckHeaderEdit = False End Function +'Get error message by code Function GetErrorMsg(ByVal errorCode As String, Optional ByVal param0 As String = "", Optional ByVal param1 As String = "") As String Dim errorList As Object: Set errorList = GetCache("errorList") Dim errorMessage As String @@ -366,10 +413,12 @@ Function GetErrorMsg(ByVal errorCode As String, Optional ByVal param0 As String GetErrorMsg = errorMessage End Function +'Convert column number to letter Function ColLetter(colNum As Long) As String ColLetter = Split(Cells(1, colNum).Address, "$")(1) End Function +'Check required field is not empty Function CheckRequired(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal errorCol As String) As Boolean Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value) If checkValue = "" Then @@ -382,6 +431,7 @@ Function CheckRequired(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum CheckRequired = True End Function +'Check character length Function CheckChar(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal charLength As Long, ByVal errorCol As String) Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value) If Len(checkValue) <> charLength Then @@ -394,6 +444,7 @@ Function CheckChar(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As CheckChar = True End Function +'Check alphanumeric characters Function CheckAlphanumeric(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal charLength As Long, ByVal errorCol As String) Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value) Dim letter As String: letter = ColLetter(colNum) @@ -412,6 +463,7 @@ Function CheckAlphanumeric(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal co CheckAlphanumeric = True End Function +'Check varchar length overflow Function CheckVarcharOver(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal varcharLength As Long, ByVal errorCol As String) Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value) If Len(checkValue) > varcharLength Then @@ -424,6 +476,7 @@ Function CheckVarcharOver(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal col CheckVarcharOver = True End Function +'Check number length overflow Function CheckNumberOver(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal numberLength As Long, ByVal errorCol As String) Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value) If Len(checkValue) > numberLength Then @@ -436,6 +489,7 @@ Function CheckNumberOver(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colN CheckNumberOver = True End Function +'Check value is 0 or 1 Function Check01(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal errorCol As String) Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value) Dim letter As String: letter = ColLetter(colNum) @@ -456,6 +510,7 @@ Function Check01(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Lo Check01 = True End Function +'Check value is 1 or 2 Function Check12(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal errorCol As String) Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value) Dim letter As String: letter = ColLetter(colNum) @@ -476,6 +531,7 @@ Function Check12(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Lo Check12 = True End Function +'Check duplicate value in column Function CheckDuplicate(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal errorCol As String) As Boolean Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value) Dim letter As String: letter = ColLetter(colNum) @@ -493,6 +549,7 @@ Function CheckDuplicate(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNu CheckDuplicate = True End Function +'Check numeric value Function CheckNumber(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal errorCol As String) As Boolean Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value) Dim letter As String: letter = ColLetter(colNum) diff --git a/src/sh/tuk/module/Common_Global_Cache.bas b/src/sh/tuk/module/Common_Global_Cache.bas index c74b164..0eb82c8 100644 --- a/src/sh/tuk/module/Common_Global_Cache.bas +++ b/src/sh/tuk/module/Common_Global_Cache.bas @@ -419,7 +419,7 @@ Private Sub RefreshSheetDict() sheetConf("AlwaysQuote") = True sheetConf("FilterRow") = 6 sheetConf("KeyCol") = 3 - sheetConf("ValueCols") = Array(4, 6, 8, 9, 10, 11, 12, 13) + sheetConf("ValueCols") = Array(4, 8, 9, 10, 11, 12, 13) Set sheetConfDict("T2") = sheetConf Debug.Print "RefreshSheetDict T2 ok." diff --git a/src/sh/tuk/sheet/M1.cls b/src/sh/tuk/sheet/M1.cls index 62139a7..8a8dcd9 100644 --- a/src/sh/tuk/sheet/M1.cls +++ b/src/sh/tuk/sheet/M1.cls @@ -59,11 +59,13 @@ Private Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol)) clearRange.Interior.Color = vbWhite + Dim errorCell As Range: Set errorCell = ws.Cells(rowNum, errorCol) + ' Check column required Dim colLetter As Variant For Each colLetter In Array("C", "D", "E", "F", "G", "I", "L") If Trim(ws.Range(colLetter & rowNum).Value) = "" Then - ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E002", colLetter & rowNum) + errorCell.Value = GetErrorMsg("E002", colLetter & rowNum) ws.Range(colLetter & rowNum).Interior.Color = RGB(255, 0, 0) Exit Sub End If @@ -73,7 +75,7 @@ Private Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As For Each colLetter In Array("H", "I", "J", "N") Dim val As String: val = Trim(ws.Range(colLetter & rowNum).Value) If val <> "" And Not IsNumeric(val) Then - ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E011", colLetter & rowNum) + errorCell.Value = GetErrorMsg("E011", colLetter & rowNum) ws.Range(colLetter & rowNum).Interior.Color = RGB(255, 0, 0) Exit Sub End If @@ -85,7 +87,7 @@ Private Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Set foundCell = ws.Range("C7:C" & lastDataRow).Find(What:=cValue, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext) If Not foundCell Is Nothing Then If foundCell.Row <> rowNum Then - ws.Cells(rowNum, errorCol).Value = "C column value is duplicated" + errorCell.Value = "C column value is duplicated" ws.Range("C" & rowNum).Interior.Color = RGB(255, 0, 0) Exit Sub End If @@ -98,14 +100,14 @@ Private Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Dim eValue As String: eValue = Trim(ws.Range("E" & rowNum).Value) If Not z1Cache.Exists(dValue) Then - ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E004", "D" & rowNum) + errorCell.Value = GetErrorMsg("E004", "D" & rowNum) ws.Range("D" & rowNum).Interior.Color = RGB(255, 0, 0) Exit Sub Else Dim valueArray As Variant valueArray = z1Cache(dValue) If Not IsArray(valueArray) Or UBound(valueArray) < 0 Then - ws.Cells(rowNum, errorCol).Value = "Invalid reference data for D column." + errorCell.Value = "Invalid reference data for D column." Exit Sub End If @@ -113,7 +115,7 @@ Private Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As expectedEValue = Trim(CStr(valueArray(0))) If eValue <> expectedEValue Then - ws.Cells(rowNum, errorCol).Value = "E column does not match reference data." + errorCell.Value = "E column does not match reference data." ws.Range("E" & rowNum).Interior.Color = RGB(255, 0, 0) Exit Sub End If @@ -123,13 +125,15 @@ Private Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Dim tokubetuList As Object: Set tokubetuList = GetCache("tokubetuList") Dim lValue As String: lValue = Trim(ws.Range("L" & rowNum).Value) If Not tokubetuList.Exists(lValue) Then - ws.Cells(rowNum, errorCol).Value = "L column does not exist." + errorCell.Value = "L column does not exist." ws.Range("L" & rowNum).Interior.Color = RGB(255, 0, 0) Exit Sub End If ' Validation passed - clear error - ws.Cells(rowNum, errorCol).ClearContents + If Not StartsWith(errorCell.Value, "W") Then + errorCell.ClearContents + End If Exit Sub ErrHandler: @@ -150,8 +154,10 @@ Private Sub Refresh(ws As Worksheet, ByVal startRow As Long, ByVal lastDataRow A Dim valsD As Variant: valsD = z1Cache(dVal) ws.Cells(r, 5).Value = valsD(0) ' Column E End If + Call BuildTokubetuDropdown(ws, "L", r) + Call BuildRenrakuDropdown(ws, "K", r) Next r - + Application.EnableEvents = True Exit Sub diff --git a/src/sh/tuk/sheet/M2.cls b/src/sh/tuk/sheet/M2.cls index f1828a6..34fd686 100644 --- a/src/sh/tuk/sheet/M2.cls +++ b/src/sh/tuk/sheet/M2.cls @@ -53,9 +53,10 @@ Private Sub Worksheet_Change(ByVal Target As Range) End If ' clear Me.Range(Me.Cells(cellI.Row, 10), Me.Cells(cellI.Row, 18)).ClearContents - Me.Cells(cellI.Row, 11).Validation.Delete Me.Range(Me.Cells(cellI.Row, 10), Me.Cells(cellI.Row, 18)).Interior.Color = vbWhite + Me.Cells(cellI.Row, 10).Validation.Delete Call CreateJDropdown(cellI.Row) + Call ChangeBackColor(cellI.Row) Next End If @@ -93,19 +94,201 @@ Finally: Application.EnableEvents = True ' End Sub +Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long) + On Error GoTo ErrHandler + + Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig() + Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName) + + Dim startCol As String: startCol = sheetConf("StartCol") + Dim endCol As String: endCol = sheetConf("EndCol") + Dim errorCol As String: errorCol = sheetConf("ErrorCol") + + Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol)) + clearRange.Interior.Color = vbWhite + + Dim errorCell As Range: Set errorCell = ws.Cells(rowNum, errorCol) + + ' Check C column in the cache + Dim m1Cache As Object: Set m1Cache = GetCache("M1") + + ' C column check + checkResult = CheckRequired(ws, rowNum, 3, errorCol) + If checkResult = False Then Exit Sub + + Dim cValue As String: cValue = Trim(ws.Range("C" & rowNum).Value) + If Not m1Cache.Exists(cValue) Then + errorCell.Value = GetErrorMsg("E004", "C" & rowNum) + ws.Range("C" & rowNum).Interior.Color = RGB(255, 0, 0) + Exit Sub + End If + + ' Check column required + Dim colLetter As Variant + For Each colLetter In Array("I", "J", "K", "L", "M") + If Trim(ws.Range(colLetter & rowNum).Value) = "" Then + errorCell.Value = GetErrorMsg("E002", colLetter & rowNum) + ws.Range(colLetter & rowNum).Interior.Color = RGB(255, 0, 0) + Exit Sub + End If + Next colLetter + + ' Check column numeric (only if has value) + Dim numericCols As Variant: numericCols = Array("L", "M", "N", "O", "P", "Q", "R") + Dim col As Variant + For Each col In numericCols + Dim val As String: val = Trim(ws.Range(col & rowNum).Value & "") + If val <> "" And Not IsNumeric(val) Then + errorCell.Value = GetErrorMsg("E011", col & rowNum) + ws.Range(col & rowNum).Interior.Color = RGB(255, 0, 0) + Exit Sub + End If + Next col + + Dim kenshuKbn As String: kenshuKbn = Trim(ws.Range("I" & rowNum).Value) + + Dim cache As Object + Dim requiredCols As Variant + Dim equaledCols As Variant + Dim emptyCols As Variant + If kenshuKbn = "1" Then + Set cache = GetCache("T1") + ' must input + equaledCols = Array("K") + requiredCols = Array("N") + emptyCols = Array("O", "P", "Q", "R") + End If + + If kenshuKbn = "2" Then + Set cache = GetCache("T2") + ' must input + equaledCols = Array("K", "L", "M", "N", "O", "P", "Q") + requiredCols = Array("N", "O", "P", "Q") + emptyCols = Array("R") + End If + + If kenshuKbn = "3" Then + Set cache = GetCache("T3") + ' must input + equaledCols = Array("K", "L", "M") + requiredCols = Array() + emptyCols = Array("N", "O", "P", "Q", "R") + End If + + ' Check J column in the T1, T2, T3 + ' code not exist check + Dim code As String: code = Trim(ws.Range("J" & rowNum).Value) + If Not cache.Exists(code) Then + errorCell.Value = GetErrorMsg("E004", "J" & rowNum) + ws.Range("J" & rowNum).Interior.Color = RGB(255, 0, 0) + Exit Sub + End If + + Dim equaledCol As Variant + Dim equaledIndex As Long + For equaledIndex = LBound(equaledCols) To UBound(equaledCols) + equaledCol = equaledCols(equaledIndex) + ' M2 value + Dim equalValue As String: equalValue = Trim(ws.Range(equaledCol & rowNum).Value) + If cache(code)(equaledIndex) <> equalValue Then + errorCell.Value = GetErrorMsg("E004", equaledCol & rowNum) + ws.Range(equaledCol & rowNum).Interior.Color = RGB(255, 0, 0) + Exit Sub + End If + Next equaledIndex + + Dim requiredCol As Variant + For Each requiredCol In requiredCols + Dim requiredValue As String: requiredValue = Trim(ws.Range(requiredCol & rowNum).Value) + If requiredValue = "" Then + errorCell.Value = GetErrorMsg("E002", requiredCol & rowNum) + ws.Range(requiredCol & rowNum).Interior.Color = RGB(255, 0, 0) + Exit Sub + End If + Next requiredCol + + Dim emptyCol As Variant + For Each emptyCol In emptyCols + Dim emptyValue As String: emptyValue = Trim(ws.Range(emptyCol & rowNum).Value) + If emptyValue <> "" Then + errorCell.Value = GetErrorMsg("E005", emptyCol & rowNum) + ws.Range(emptyCol & rowNum).Interior.Color = RGB(255, 0, 0) + Exit Sub + End If + Next emptyCol + + ' check Duplicate + Dim i As Long + For i = 7 To rowNum - 1 + If Trim(ws.Cells(i, "C").Value) = cValue And Trim(ws.Cells(i, "I").Value) = kenshuKbn And Trim(ws.Cells(i, "J").Value) = code Then + errorCell.Value = GetErrorMsg("E013", i, code) + ws.Cells(rowNum, "C").Interior.Color = RGB(255, 0, 0) + Exit Sub + End If + Next i + + errorCell.ClearContents + Application.EnableEvents = False + Call ChangeBackColor(rowNum) + Application.EnableEvents = True + Exit Sub + +ErrHandler: + lastErrorMsg = Err.Description +End Sub + +' obtain T1/T2/T3 cache data, and update column K +Private Sub Refresh(ws As Worksheet, ByVal startRow As Long, ByVal lastDataRow As Long) + Dim kenshuList As Object: Set kenshuList = GetCache("kenshuList") + + Application.EnableEvents = False + On Error GoTo ErrorHandler + + Dim r As Long + For r = startRow To lastDataRow + Dim cValue As String: cValue = Trim(ws.Cells(r, 3).Value) ' Column C + + ' Skip if C column is empty + If cValue = "" Then + GoTo NextRow + End If + + ' Reuse FillFromM1 method to fill D-H columns + Call FillFromM1(ws, r) + Call BuildKenshuDropdown(ws, "I", r) + + ' Reuse FillKFromJ method to fill J-K columns + Dim iValue As String: iValue = Trim(ws.Cells(r, 9).Value) ' Column I + If iValue <> "" And kenshuList.Exists(iValue) Then + Call CreateJDropdown(r) + Call ChangeBackColor(r) + Call FillKFromJ(ws, r) + End If + +NextRow: + Next r + + Application.EnableEvents = True + Exit Sub + +ErrorHandler: + Application.EnableEvents = True + Err.Raise ERR_CACHE_NOT_FOUND, "M2.Refresh", "Failed to refresh M2: " & Err.Description +End Sub + Private Sub FillKFromJ(ByVal ws As Worksheet, ByVal rowNum As Long) - Dim iValue As String: iValue = Trim(ws.Range("I" & rowNum).Value) + Dim kenshu As String: kenshu = Trim(ws.Range("I" & rowNum).Value) Dim jValue As String: jValue = Trim(ws.Range("J" & rowNum).Value) Dim code As String: code = GetCode(jValue) If jValue = "" Then - ws.Range("K" & rowNum).ClearContents + ws.Range(ws.Cells(rowNum, "K"), ws.Cells(rowNum, "R")).ClearContents Exit Sub End If ' Get cache based on I column value Dim cache As Object - Select Case iValue + Select Case kenshu Case "1" Set cache = GetCache("T1") Case "2" @@ -119,7 +302,6 @@ Private Sub FillKFromJ(ByVal ws As Worksheet, ByVal rowNum As Long) If cache Is Nothing Then Exit Sub ' Check if J value exists in cache - If cache.Exists(code) Then Dim cacheVal As Variant: cacheVal = cache(code) ws.Range("J" & rowNum).Value = Trim(code) @@ -130,12 +312,12 @@ Private Sub FillKFromJ(ByVal ws As Worksheet, ByVal rowNum As Long) Case "1" Exit Sub Case "2" - ws.Range("L" & rowNum).Value = Trim(cacheVal(2)) - ws.Range("M" & rowNum).Value = Trim(cacheVal(3)) - ws.Range("N" & rowNum).Value = Trim(cacheVal(4)) - ws.Range("O" & rowNum).Value = Trim(cacheVal(5)) - ws.Range("P" & rowNum).Value = Trim(cacheVal(6)) - ws.Range("Q" & rowNum).Value = Trim(cacheVal(7)) + ws.Range("L" & rowNum).Value = Trim(cacheVal(1)) + ws.Range("M" & rowNum).Value = Trim(cacheVal(2)) + ws.Range("N" & rowNum).Value = Trim(cacheVal(3)) + ws.Range("O" & rowNum).Value = Trim(cacheVal(4)) + ws.Range("P" & rowNum).Value = Trim(cacheVal(5)) + ws.Range("Q" & rowNum).Value = Trim(cacheVal(6)) Case "3" ws.Range("L" & rowNum).Value = Trim(cacheVal(1)) ws.Range("M" & rowNum).Value = Trim(cacheVal(2)) @@ -145,39 +327,6 @@ Private Sub FillKFromJ(ByVal ws As Worksheet, ByVal rowNum As Long) End Sub -Private Sub CreateJDropdown(ByVal rowNum As Long) - Dim iValue As String: iValue = Trim(Me.Range("I" & rowNum).Value) - Dim targetCell As Range: Set targetCell = Me.Range("J" & rowNum) - - ' Clear existing validation - targetCell.Validation.Delete - targetCell.ClearContents - - ' Get cache based on I column value - Dim cache As Object - Select Case iValue - Case "1" - Set cache = GetCache("T1") - Me.Range("O" & rowNum).Interior.Color = RGB(192, 192, 192) - Me.Range("P" & rowNum).Interior.Color = RGB(192, 192, 192) - Me.Range("Q" & rowNum).Interior.Color = RGB(192, 192, 192) - Case "2" - Set cache = GetCache("T2") - Case "3" - Set cache = GetCache("T3") - Me.Range("N" & rowNum).Interior.Color = RGB(192, 192, 192) - Me.Range("O" & rowNum).Interior.Color = RGB(192, 192, 192) - Me.Range("P" & rowNum).Interior.Color = RGB(192, 192, 192) - Me.Range("Q" & rowNum).Interior.Color = RGB(192, 192, 192) - Case Else - Exit Sub - End Select - - If cache Is Nothing Then Exit Sub - - Call BuildDropdownFromCacheNamedRange(Me, "J", rowNum, "T" & iValue) -End Sub - Private Sub FillFromM1(ByVal ws As Worksheet, ByVal rowNum As Long) Dim m1Cache As Object: Set m1Cache = GetCache("M1") Dim cValue As String: cValue = Trim(ws.Range("C" & rowNum).Value) @@ -221,197 +370,41 @@ Private Sub ClearRowData(ByVal ws As Worksheet, ByVal rowNum As Long) ws.Cells(rowNum, "S").ClearContents End Sub -Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long) - On Error GoTo ErrHandler +Private Sub CreateJDropdown(ByVal rowNum As Long) + Dim kenshu As String: kenshu = Trim(Me.Range("I" & rowNum).Value) + Dim targetCell As Range: Set targetCell = Me.Range("J" & rowNum) - Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig() - Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName) - - Dim startCol As String: startCol = sheetConf("StartCol") - Dim endCol As String: endCol = sheetConf("EndCol") - Dim errorCol As String: errorCol = sheetConf("ErrorCol") - - Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol)) - clearRange.Interior.Color = vbWhite - - ' Check C column in the cache - Dim m1Cache As Object: Set m1Cache = GetCache("M1") - - ' C column check - checkResult = CheckRequired(ws, rowNum, 3, errorCol) - If checkResult = False Then Exit Sub - - Dim cValue As String: cValue = Trim(ws.Range("C" & rowNum).Value) - If Not m1Cache.Exists(cValue) Then - ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E004", "C" & rowNum) - ws.Range("C" & rowNum).Interior.Color = RGB(255, 0, 0) + ' Clear existing validation + targetCell.Validation.Delete + If kenshu = "" Then Exit Sub - End If - - ' Check column required - Dim colLetter As Variant - For Each colLetter In Array("I", "J", "K", "L", "M") - If Trim(ws.Range(colLetter & rowNum).Value) = "" Then - ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E002", colLetter & rowNum) - ws.Range(colLetter & rowNum).Interior.Color = RGB(255, 0, 0) - Exit Sub - End If - Next colLetter + End If + Call BuildDropdownFromCacheNamedRange(Me, "J", rowNum, "T" & kenshu) +End Sub - ' Check column numeric (only if has value) - Dim numericCols As Variant: numericCols = Array("L", "M", "N", "O", "P", "Q", "R") - Dim col As Variant - For Each col In numericCols - Dim val As String: val = Trim(ws.Range(col & rowNum).Value & "") - If val <> "" And Not IsNumeric(val) Then - ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E011", col & rowNum) - ws.Range(col & rowNum).Interior.Color = RGB(255, 0, 0) - Exit Sub - End If - Next col +' change back color by I colum kennshu +Private Sub ChangeBackColor(ByVal rowNum As Long) + Dim kenshu As String: kenshu = Trim(Me.Range("I" & rowNum).Value) + If kenshu = "" Then + Exit Sub + End If - ' Check J column in the T1, T2, T3 - Dim code As String: code = Trim(ws.Range("J" & rowNum).Value) - Dim name As String: name = Trim(ws.Range("K" & rowNum).Value) - Dim valueL As String: valueL = Trim(ws.Range("L" & rowNum).Value) - Dim valueM As String: valueM = Trim(ws.Range("M" & rowNum).Value) - Dim valueN As String: valueN = Trim(ws.Range("N" & rowNum).Value) - Dim valueO As String: valueO = Trim(ws.Range("O" & rowNum).Value) - Dim valueP As String: valueP = Trim(ws.Range("P" & rowNum).Value) - Dim valueQ As String: valueQ = Trim(ws.Range("Q" & rowNum).Value) + Me.Range("R" & rowNum).Interior.Color = RGB(192, 192, 192) + ' Get cache based on I column value Dim cache As Object - Dim requiredCols As Variant - Dim equaledCols As Variant - Dim emptyCols As Variant - If kenshuKbn = "1" Then - Set cache = GetCache("T1") - ' must input - equaledCols = Array("K") - requiredCols = Array("N") - emptyCols = Array("O", "P", "Q", "R") - End If - - If kenshuKbn = "2" Then - Set cache = GetCache("T2") - ' must input - equaledCols = Array("K", "L", "M", "N", "O", "P", "Q") - requiredCols = Array("N", "O", "P", "Q") - emptyCols = Array("R") - End If - - If kenshuKbn = "3" Then - Set cache = GetCache("T3") - ' must input - equaledCols = Array("K", "L", "M") - requiredCols = Array() - emptyCols = Array("N", "O", "P", "Q", "R") - End If - - ' code not exist check - If Not cache.Exists(code) Then - ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E004", "J" & rowNum) - ws.Range("J" & rowNum).Interior.Color = RGB(255, 0, 0) - Exit Sub - End If - - ' Dim equaledColIndex As Long - ' For equaledColIndex = 0 To - - ' Dim equaledCol As Variant - ' For Each equaledCol In equaledCols - ' Dim equalValue As String: equalValue = Trim(ws.Range(equaledCol & rowNum).Value) - ' cache - ' If cache(code)(0) <> name Then - ' Exit Sub - ' End If - ' Me.Range(equaledCol & rowNum).Validation.Delete - ' Next equaledCol - - Dim requiredCol As Variant - For Each requiredCol In requiredCols - Dim requiredValue As String: requiredValue = Trim(ws.Range(requiredCol & rowNum).Value) - If requiredValue = "" Then - ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E002", requiredCol & rowNum) - ws.Range(requiredCol & rowNum).Interior.Color = RGB(255, 0, 0) - Exit Sub - End If - Next requiredCol - - Dim emptyCol As Variant - For Each emptyCol In emptyCols - Dim emptyValue As String: emptyValue = Trim(ws.Range(emptyCol & rowNum).Value) - If emptyValue <> "" Then - ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E005", emptyCol & rowNum) - ws.Range(emptyCol & rowNum).Interior.Color = RGB(255, 0, 0) - Exit Sub - End If - Next emptyCol - - ' check Duplicate - Dim i As Long - For i = 7 To rowNum - 1 - If Trim(ws.Cells(i, "C").Value) = cValue And Trim(ws.Cells(i, "I").Value) = kenshuKbn And Trim(ws.Cells(i, "J").Value) = code Then - ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E013", i, checkValue) - ws.Cells(rowNum, "C").Interior.Color = RGB(255, 0, 0) + Select Case kenshu + Case "1" + Me.Range("O" & rowNum).Interior.Color = RGB(192, 192, 192) + Me.Range("P" & rowNum).Interior.Color = RGB(192, 192, 192) + Me.Range("Q" & rowNum).Interior.Color = RGB(192, 192, 192) + Case "2" Exit Sub - End If - If Trim(ws.Cells(i, "C").Value) = cValue And Trim(ws.Cells(i, "I").Value) = kenshuKbn And Trim(ws.Cells(i, "K").Value) = name Then - ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E013", i, checkValue) - ws.Cells(rowNum, "C").Interior.Color = RGB(255, 0, 0) + Case "3" + Me.Range("N" & rowNum).Interior.Color = RGB(192, 192, 192) + Me.Range("O" & rowNum).Interior.Color = RGB(192, 192, 192) + Me.Range("P" & rowNum).Interior.Color = RGB(192, 192, 192) + Me.Range("Q" & rowNum).Interior.Color = RGB(192, 192, 192) + Case Else Exit Sub - End If - Next i - - ws.Cells(rowNum, errorCol).ClearContents - Exit Sub - -ErrHandler: - lastErrorMsg = Err.Description -End Sub - -Public Sub ImportCSVAndTriggerChange(ws As Worksheet, ByVal lastDataRow As Long) - Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig() - Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName) - - Dim startRow As Long: startRow = sheetConf("StartRow") - Dim i As Long - For i = startRow To lastDataRow - Call FillFromM1(ws, i) - Next i -End Sub - -' obtain T1/T2/T3 cache data, and update column K -Private Sub Refresh(ws As Worksheet, ByVal startRow As Long, ByVal lastDataRow As Long) - Dim kenshuList As Object: Set kenshuList = GetCache("kenshuList") - - Application.EnableEvents = False - On Error GoTo ErrorHandler - - Dim r As Long - For r = startRow To lastDataRow - Dim cValue As String: cValue = Trim(ws.Cells(r, 3).Value) ' Column C - - ' Skip if C column is empty - If cValue = "" Then - GoTo NextRow - End If - - ' Reuse FillFromM1 method to fill D-H columns - Call FillFromM1(ws, r) - - ' Reuse FillKFromJ method to fill J-K columns - Dim iValue As String: iValue = Trim(ws.Cells(r, 9).Value) ' Column I - If iValue <> "" And kenshuList.Exists(iValue) Then - Call FillKFromJ(ws, r) - End If - -NextRow: - Next r - - Application.EnableEvents = True - Exit Sub - -ErrorHandler: - Application.EnableEvents = True - Err.Raise ERR_CACHE_NOT_FOUND, "M2.Refresh", "Failed to refresh M2: " & Err.Description + End Select End Sub diff --git a/通勤手当テンプレート20260515.xlsm b/通勤手当テンプレート20260515.xlsm index c858a16..26f5489 100644 Binary files a/通勤手当テンプレート20260515.xlsm and b/通勤手当テンプレート20260515.xlsm differ