20260515指摘対応8

This commit is contained in:
guanxiangwei
2026-05-21 16:02:08 +09:00
parent bee1cd9810
commit 0a633d711c
6 changed files with 315 additions and 252 deletions

View File

@@ -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

View File

@@ -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)

View File

@@ -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."

View File

@@ -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

View File

@@ -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