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 End If
' === Step 4: Clear all data rows before import === ' === Step 4: Clear all data rows before import ===
Call ClearDataRows(ws)
Application.ScreenUpdating = False Application.ScreenUpdating = False
Application.EnableEvents = False Application.EnableEvents = False
Call ClearDataRows(ws)
' === Step 5: Write CSV data to worksheet === ' === Step 5: Write CSV data to worksheet ===
Dim colLetters As Variant: colLetters = cfg("HeaderColumns") 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 Application.Run "M1.ValidateWarn", ws, lastDataRow
End If End If
Do_Fit ws GoTo FinallyExit
Exit Sub Exit Sub
ErrorHandler: ErrorHandler:
HandleError "Do_Validation" HandleError "Do_Validation"
GoTo FinallyExit
FinallyExit:
Do_Fit ws
ClearFormatsBelowLastDataRow ws
End Sub End Sub
' ============================================================ ' ============================================================
@@ -258,9 +263,11 @@ Private Sub DO_CSV_Export(ws As Excel.Worksheet)
Dim colLetters As Variant: colLetters = sheetConf("HeaderColumns") Dim colLetters As Variant: colLetters = sheetConf("HeaderColumns")
Dim r As Long Dim r As Long
Dim colIndex As Long
For r = startRow To lastDataRow For r = startRow To lastDataRow
For colIdx = 0 To expectedColumnCount - 1 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 Next colIdx
dataRow = dataRow + 1 dataRow = dataRow + 1
Next r Next r

View File

@@ -45,7 +45,7 @@ ErrorHandler:
Err.Raise ERR_CONFIG_INVALID, "GetCSVHeader", "Invalid column letter in HeaderColumns: '" & colLetters(i) & "'" Err.Raise ERR_CONFIG_INVALID, "GetCSVHeader", "Invalid column letter in HeaderColumns: '" & colLetters(i) & "'"
End Function End Function
' ' Clean CSV field: add quote prefix for formula-like values
Function CleanCSVField(ByVal inputStr As String) As String Function CleanCSVField(ByVal inputStr As String) As String
Dim s As String Dim s As String
s = Trim(inputStr) s = Trim(inputStr)
@@ -62,10 +62,12 @@ Function CleanCSVField(ByVal inputStr As String) As String
CleanCSVField = s CleanCSVField = s
End Function End Function
' Get last data row in specified column
Function GetLastDataRow(ByVal ws As Worksheet, ByVal columnNum As Long) As Long Function GetLastDataRow(ByVal ws As Worksheet, ByVal columnNum As Long) As Long
GetLastDataRow = ws.Cells(ws.Rows.Count, columnNum).End(xlUp).Row GetLastDataRow = ws.Cells(ws.Rows.Count, columnNum).End(xlUp).Row
End Function End Function
' Check if array contains value
Function Contains(ByVal arr As Variant, ByVal value As String) As Boolean Function Contains(ByVal arr As Variant, ByVal value As String) As Boolean
Dim i As Long Dim i As Long
For i = 0 To UBound(arr) For i = 0 To UBound(arr)
@@ -184,7 +186,7 @@ ErrHandler:
Err.Raise Err.Number, Err.Source, Err.Description Err.Raise Err.Number, Err.Source, Err.Description
End Function End Function
' obtain ' Get last data row in specified column
Function GetLastDataRowInRange(ws As Worksheet) As Long Function GetLastDataRowInRange(ws As Worksheet) As Long
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig() 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 Err.Raise ERR_CONFIG_INVALID, "GetLastDataRowInRange", "Invalid column letter for sheet: " & ws.CodeName
End Function 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) 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 If rowRow >= 7 Then
Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowRow, startCol), ws.Cells(rowRow, endCol)) 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 If
End Function End Function
'Clear all data rows from startRow to lastDataRow
Sub ClearDataRows(ByVal ws As Worksheet) Sub ClearDataRows(ByVal ws As Worksheet)
' ' Clear data and format from startRow to lastDataRow
Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig() Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
' '
If Not sheetConfDict.Exists(ws.CodeName) Then 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 startCol As String: startCol = sheetConf("StartCol")
Dim endCol As String: endCol = sheetConf("EndCol") Dim endCol As String: endCol = sheetConf("EndCol")
Dim errorCol As String: errorCol = sheetConf("ErrorCol") Dim errorCol As String: errorCol = sheetConf("ErrorCol")
'
Application.EnableEvents = False
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws) Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws)
'
If lastDataRow >= startRow Then If lastDataRow >= startRow Then
Dim clearRange As Range Dim clearRange As Range
Set clearRange = ws.Range(ws.Cells(startRow, ws.Range(startCol & "1").Column), ws.Cells(lastDataRow, ws.Range(endCol & "1").Column)) 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 clearErrorRange.Interior.Color = vbWhite
End If End If
End If End If
' Clear formats below lastDataRow (including dropdowns)
Application.EnableEvents = True
Call ClearFormatsBelowLastDataRow(ws)
End Sub 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 Function MakeSelect(ByVal code As String, ByVal value As String) As String
MakeSelect = Trim(code) & ":" & Trim(value) MakeSelect = Trim(code) & ":" & Trim(value)
End Function End Function
@@ -316,16 +362,16 @@ Public Function FormatDateInput(ByVal inputStr As String) As String
End If End If
End Function End Function
'Check header edit protection
Function CheckHeaderEdit(ByVal ws As Worksheet, ByVal Target As Range) As Boolean Function CheckHeaderEdit(ByVal ws As Worksheet, ByVal Target As Range) As Boolean
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 headerRow As Long: headerRow = sheetConf("HeaderRow")
Dim filterRow As Long: filterRow = sheetConf("FilterRow") Dim filterRow As Long: filterRow = sheetConf("FilterRow")
' Check header row (headerRow) cannot be edited ' Check header row (headerRow) cannot be edited
Dim r As Long Dim r As Long
For r = Target.Row To Target.Row + Target.Rows.Count - 1 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 Application.EnableEvents = False
MsgBox "Header or type definition row cannot be edited.", vbExclamation MsgBox "Header or type definition row cannot be edited.", vbExclamation
Application.Undo Application.Undo
@@ -355,6 +401,7 @@ Function CheckHeaderEdit(ByVal ws As Worksheet, ByVal Target As Range) As Boolea
CheckHeaderEdit = False CheckHeaderEdit = False
End Function 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 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 errorList As Object: Set errorList = GetCache("errorList")
Dim errorMessage As String Dim errorMessage As String
@@ -366,10 +413,12 @@ Function GetErrorMsg(ByVal errorCode As String, Optional ByVal param0 As String
GetErrorMsg = errorMessage GetErrorMsg = errorMessage
End Function End Function
'Convert column number to letter
Function ColLetter(colNum As Long) As String Function ColLetter(colNum As Long) As String
ColLetter = Split(Cells(1, colNum).Address, "$")(1) ColLetter = Split(Cells(1, colNum).Address, "$")(1)
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 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) Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
If checkValue = "" Then If checkValue = "" Then
@@ -382,6 +431,7 @@ Function CheckRequired(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum
CheckRequired = True CheckRequired = True
End Function 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) 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) Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
If Len(checkValue) <> charLength Then If Len(checkValue) <> charLength Then
@@ -394,6 +444,7 @@ Function CheckChar(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As
CheckChar = True CheckChar = True
End Function 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) 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 checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
Dim letter As String: letter = ColLetter(colNum) 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 CheckAlphanumeric = True
End Function 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) 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) Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
If Len(checkValue) > varcharLength Then If Len(checkValue) > varcharLength Then
@@ -424,6 +476,7 @@ Function CheckVarcharOver(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal col
CheckVarcharOver = True CheckVarcharOver = True
End Function 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) 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) Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
If Len(checkValue) > numberLength Then If Len(checkValue) > numberLength Then
@@ -436,6 +489,7 @@ Function CheckNumberOver(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colN
CheckNumberOver = True CheckNumberOver = True
End Function 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) 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 checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
Dim letter As String: letter = ColLetter(colNum) 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 Check01 = True
End Function 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) 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 checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
Dim letter As String: letter = ColLetter(colNum) 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 Check12 = True
End Function 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 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 checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
Dim letter As String: letter = ColLetter(colNum) 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 CheckDuplicate = True
End Function 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 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 checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
Dim letter As String: letter = ColLetter(colNum) Dim letter As String: letter = ColLetter(colNum)

View File

@@ -419,7 +419,7 @@ Private Sub RefreshSheetDict()
sheetConf("AlwaysQuote") = True sheetConf("AlwaysQuote") = True
sheetConf("FilterRow") = 6 sheetConf("FilterRow") = 6
sheetConf("KeyCol") = 3 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 Set sheetConfDict("T2") = sheetConf
Debug.Print "RefreshSheetDict T2 ok." 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)) Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol))
clearRange.Interior.Color = vbWhite clearRange.Interior.Color = vbWhite
Dim errorCell As Range: Set errorCell = ws.Cells(rowNum, errorCol)
' Check column required ' Check column required
Dim colLetter As Variant Dim colLetter As Variant
For Each colLetter In Array("C", "D", "E", "F", "G", "I", "L") For Each colLetter In Array("C", "D", "E", "F", "G", "I", "L")
If Trim(ws.Range(colLetter & rowNum).Value) = "" Then 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) ws.Range(colLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
End If 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") For Each colLetter In Array("H", "I", "J", "N")
Dim val As String: val = Trim(ws.Range(colLetter & rowNum).Value) Dim val As String: val = Trim(ws.Range(colLetter & rowNum).Value)
If val <> "" And Not IsNumeric(val) Then 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) ws.Range(colLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
End If 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) 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 Not foundCell Is Nothing Then
If foundCell.Row <> rowNum 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) ws.Range("C" & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
End If 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) Dim eValue As String: eValue = Trim(ws.Range("E" & rowNum).Value)
If Not z1Cache.Exists(dValue) Then 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) ws.Range("D" & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
Else Else
Dim valueArray As Variant Dim valueArray As Variant
valueArray = z1Cache(dValue) valueArray = z1Cache(dValue)
If Not IsArray(valueArray) Or UBound(valueArray) < 0 Then 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 Exit Sub
End If End If
@@ -113,7 +115,7 @@ Private Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
expectedEValue = Trim(CStr(valueArray(0))) expectedEValue = Trim(CStr(valueArray(0)))
If eValue <> expectedEValue Then 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) ws.Range("E" & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
End If 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 tokubetuList As Object: Set tokubetuList = GetCache("tokubetuList")
Dim lValue As String: lValue = Trim(ws.Range("L" & rowNum).Value) Dim lValue As String: lValue = Trim(ws.Range("L" & rowNum).Value)
If Not tokubetuList.Exists(lValue) Then 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) ws.Range("L" & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
End If End If
' Validation passed - clear error ' Validation passed - clear error
ws.Cells(rowNum, errorCol).ClearContents If Not StartsWith(errorCell.Value, "W") Then
errorCell.ClearContents
End If
Exit Sub Exit Sub
ErrHandler: 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) Dim valsD As Variant: valsD = z1Cache(dVal)
ws.Cells(r, 5).Value = valsD(0) ' Column E ws.Cells(r, 5).Value = valsD(0) ' Column E
End If End If
Call BuildTokubetuDropdown(ws, "L", r)
Call BuildRenrakuDropdown(ws, "K", r)
Next r Next r
Application.EnableEvents = True Application.EnableEvents = True
Exit Sub Exit Sub

View File

@@ -53,9 +53,10 @@ Private Sub Worksheet_Change(ByVal Target As Range)
End If End If
' clear ' clear
Me.Range(Me.Cells(cellI.Row, 10), Me.Cells(cellI.Row, 18)).ClearContents 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.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 CreateJDropdown(cellI.Row)
Call ChangeBackColor(cellI.Row)
Next Next
End If End If
@@ -93,19 +94,201 @@ Finally:
Application.EnableEvents = True ' Application.EnableEvents = True '
End Sub 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) 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 jValue As String: jValue = Trim(ws.Range("J" & rowNum).Value)
Dim code As String: code = GetCode(jValue) Dim code As String: code = GetCode(jValue)
If jValue = "" Then If jValue = "" Then
ws.Range("K" & rowNum).ClearContents ws.Range(ws.Cells(rowNum, "K"), ws.Cells(rowNum, "R")).ClearContents
Exit Sub Exit Sub
End If End If
' Get cache based on I column value ' Get cache based on I column value
Dim cache As Object Dim cache As Object
Select Case iValue Select Case kenshu
Case "1" Case "1"
Set cache = GetCache("T1") Set cache = GetCache("T1")
Case "2" Case "2"
@@ -119,7 +302,6 @@ Private Sub FillKFromJ(ByVal ws As Worksheet, ByVal rowNum As Long)
If cache Is Nothing Then Exit Sub If cache Is Nothing Then Exit Sub
' Check if J value exists in cache ' Check if J value exists in cache
If cache.Exists(code) Then If cache.Exists(code) Then
Dim cacheVal As Variant: cacheVal = cache(code) Dim cacheVal As Variant: cacheVal = cache(code)
ws.Range("J" & rowNum).Value = Trim(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" Case "1"
Exit Sub Exit Sub
Case "2" Case "2"
ws.Range("L" & rowNum).Value = Trim(cacheVal(2)) ws.Range("L" & rowNum).Value = Trim(cacheVal(1))
ws.Range("M" & rowNum).Value = Trim(cacheVal(3)) ws.Range("M" & rowNum).Value = Trim(cacheVal(2))
ws.Range("N" & rowNum).Value = Trim(cacheVal(4)) ws.Range("N" & rowNum).Value = Trim(cacheVal(3))
ws.Range("O" & rowNum).Value = Trim(cacheVal(5)) ws.Range("O" & rowNum).Value = Trim(cacheVal(4))
ws.Range("P" & rowNum).Value = Trim(cacheVal(6)) ws.Range("P" & rowNum).Value = Trim(cacheVal(5))
ws.Range("Q" & rowNum).Value = Trim(cacheVal(7)) ws.Range("Q" & rowNum).Value = Trim(cacheVal(6))
Case "3" Case "3"
ws.Range("L" & rowNum).Value = Trim(cacheVal(1)) ws.Range("L" & rowNum).Value = Trim(cacheVal(1))
ws.Range("M" & rowNum).Value = Trim(cacheVal(2)) 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 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) Private Sub FillFromM1(ByVal ws As Worksheet, ByVal rowNum As Long)
Dim m1Cache As Object: Set m1Cache = GetCache("M1") Dim m1Cache As Object: Set m1Cache = GetCache("M1")
Dim cValue As String: cValue = Trim(ws.Range("C" & rowNum).Value) 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 ws.Cells(rowNum, "S").ClearContents
End Sub End Sub
Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long) Private Sub CreateJDropdown(ByVal rowNum As Long)
On Error GoTo ErrHandler 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() ' Clear existing validation
Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName) targetCell.Validation.Delete
If kenshu = "" Then
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)
Exit Sub Exit Sub
End If End If
Call BuildDropdownFromCacheNamedRange(Me, "J", rowNum, "T" & kenshu)
' Check column required End Sub
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
' Check column numeric (only if has value) ' change back color by I colum kennshu
Dim numericCols As Variant: numericCols = Array("L", "M", "N", "O", "P", "Q", "R") Private Sub ChangeBackColor(ByVal rowNum As Long)
Dim col As Variant Dim kenshu As String: kenshu = Trim(Me.Range("I" & rowNum).Value)
For Each col In numericCols If kenshu = "" Then
Dim val As String: val = Trim(ws.Range(col & rowNum).Value & "") Exit Sub
If val <> "" And Not IsNumeric(val) Then End If
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
' Check J column in the T1, T2, T3 Me.Range("R" & rowNum).Interior.Color = RGB(192, 192, 192)
Dim code As String: code = Trim(ws.Range("J" & rowNum).Value) ' Get cache based on I column 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)
Dim cache As Object Dim cache As Object
Dim requiredCols As Variant Select Case kenshu
Dim equaledCols As Variant Case "1"
Dim emptyCols As Variant Me.Range("O" & rowNum).Interior.Color = RGB(192, 192, 192)
If kenshuKbn = "1" Then Me.Range("P" & rowNum).Interior.Color = RGB(192, 192, 192)
Set cache = GetCache("T1") Me.Range("Q" & rowNum).Interior.Color = RGB(192, 192, 192)
' must input Case "2"
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)
Exit Sub Exit Sub
End If Case "3"
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 Me.Range("N" & rowNum).Interior.Color = RGB(192, 192, 192)
ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E013", i, checkValue) Me.Range("O" & rowNum).Interior.Color = RGB(192, 192, 192)
ws.Cells(rowNum, "C").Interior.Color = RGB(255, 0, 0) Me.Range("P" & rowNum).Interior.Color = RGB(192, 192, 192)
Me.Range("Q" & rowNum).Interior.Color = RGB(192, 192, 192)
Case Else
Exit Sub Exit Sub
End If End Select
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 Sub End Sub