' ============================================================ ' Module Name: Master_Kukan ' Module Desc: M1 Kukan master data management (import/export/validate) ' Module Methods: ' - CreateEnumDropdown ' - Worksheet_Change ' - Validate ' ============================================================ Private Sub Worksheet_Change(ByVal Target As Range) Dim HasHeaderEdit As Boolean: HasHeaderEdit = CheckHeaderEdit(Me, Target) If HasHeaderEdit = True Then Exit Sub Application.EnableEvents = False On Error GoTo Finally ' Multi-cell selection not processed If Target.Count > 1 Then GoTo Finally ' === Column C changes: Create L column dropdown === If Target.Column = 3 And Target.Row >= 7 Then Dim cell As Range For Each cell In Target If Trim(cell.Value) = "" Then Call ClearDataRow(Me, cell.Row) Else Call BuildTokubetuDropdown(Me, "L", cell.Row) Call BuildRenrakuDropdown(Me, "K", cell.Row) End If Next End If ' === Column D changes: Fill E column === If Target.Column = 4 And Target.Row >= 7 Then Dim z1Cache As Object: Set z1Cache = GetCache(CACHE_Z1) Dim z4Rosen As Object: Set z4Rosen = GetCache(CACHE_Z4ROSEN) Dim cellD As Range For Each cellD In Target Dim dVal As String: dVal = Trim(cellD.Value) If dVal = "" Then Me.Cells(cellD.Row, 5).ClearContents Me.Cells(cellD.Row, 6).ClearContents Me.Cells(cellD.Row, 7).ClearContents Me.Cells(cellD.Row, 6).Validation.Delete Me.Cells(cellD.Row, 7).Validation.Delete Else If z1Cache.Exists(dVal) Then Dim kikan As Variant: kikan = z1Cache(dVal) Dim kikanName As String: kikanName = kikan(0) Me.Cells(cellD.Row, 5).Value = kikanName If z4Rosen.Exists(kikanName) Then Call BuildZ4StationFromDropdown(Me, "F", cellD.Row, kikanName) Dim stations As Object: Set stations = z4Rosen(kikanName) Dim fromCell As Range: Set fromCell = Me.Cells(cellD.Row, 6) Dim fromStation As String: fromStation = Trim(fromCell.Value) If Not stations.Exists(fromStation) Or fromStation = "" Then fromCell.ClearContents Me.Cells(cellD.Row, 7).ClearContents Me.Cells(cellD.Row, 7).Validation.Delete Else Call BuildZ4StationToDropdown(Me, "G", cellD.Row, kikanName, fromStation) Dim toCell As Range: Set toCell = Me.Cells(cellD.Row, 7) Dim toStation As String: toStation = Trim(toCell.Value) If Not stations.Exists(toStation) Or toStation = "" Then toCell.ClearContents End If End If Else Me.Cells(cellD.Row, 6).ClearContents Me.Cells(cellD.Row, 7).ClearContents Me.Cells(cellD.Row, 6).Validation.Delete Me.Cells(cellD.Row, 7).Validation.Delete End If Else Me.Cells(cellD.Row, 5).ClearContents Me.Cells(cellD.Row, 6).ClearContents Me.Cells(cellD.Row, 7).ClearContents Me.Cells(cellD.Row, 6).Validation.Delete Me.Cells(cellD.Row, 7).Validation.Delete End If End If Next End If ' === Column E changes (rosen name): Build F column (station from) dropdown === ' If Target.Column = 4 And Target.Row >= 7 Then ' Dim cellE As Range ' For Each cellE In Target ' Dim rosenVal As String: rosenVal = Trim(cellE.Value) ' If rosenVal = "" Then ' Me.Cells(cellE.Row, 6).ClearContents ' Me.Cells(cellE.Row, 8).ClearContents ' Me.Cells(cellE.Row, 6).Validation.Delete ' Me.Cells(cellE.Row, 8).Validation.Delete ' Else ' Call BuildZ4StationFromDropdown(Me, "F", cellE.Row, rosenVal) ' End If ' Next ' End If ' === Column F changes (station from): Build H column (station to) dropdown === If Target.Column = 6 And Target.Row >= 7 Then Dim cellF As Range For Each cellF In Target Dim stationFrom As String: stationFrom = Trim(cellF.Value) Dim rosenForH As String: rosenForH = Trim(Me.Cells(cellF.Row, 5).Value) If stationFrom = "" Then Me.Cells(cellF.Row, 7).ClearContents Me.Cells(cellF.Row, 7).Validation.Delete Else Call BuildZ4StationToDropdown(Me, "G", cellF.Row, rosenForH, stationFrom) End If Next End If Application.EnableEvents = True Exit Sub Finally: HandleError "Worksheet_Change" Application.EnableEvents = True End Sub ' Prevent insert/delete row in header area Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig() Dim sheetConf As Object: Set sheetConf = sheetConfDict(Me.CodeName) Dim filterRow As Long: filterRow = sheetConf("FilterRow") If Target.Row < filterRow + 1 Then Cancel = True MsgBox "Cannot insert or delete row in header area.", vbExclamation End If End Sub Private 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 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 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 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 errorCell.Value = GetErrorMsg("E011", colLetter & rowNum) ws.Range(colLetter & rowNum).Interior.Color = RGB(255, 0, 0) Exit Sub End If Next colLetter ' Check C column repeat Dim cValue As String: cValue = Trim(ws.Range("C" & rowNum).Value) Dim foundCell As Range 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 errorCell.Value = "C column value is duplicated" ws.Range("C" & rowNum).Interior.Color = RGB(255, 0, 0) Exit Sub End If End If ' Check D and E column in the cache Dim z1Cache As Object: Set z1Cache = GetCache(CACHE_Z1) Dim dValue As String: dValue = Trim(ws.Range("D" & rowNum).Value) Dim eValue As String: eValue = Trim(ws.Range("E" & rowNum).Value) If Not z1Cache.Exists(dValue) Then 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 errorCell.Value = "Invalid reference data for D column." Exit Sub End If Dim expectedEValue As String expectedEValue = Trim(CStr(valueArray(0))) If eValue <> expectedEValue Then errorCell.Value = "E column does not match reference data." ws.Range("E" & rowNum).Interior.Color = RGB(255, 0, 0) Exit Sub End If End If ' Check L column in the tokubetuList 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 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 If Not StartsWith(errorCell.Value, "W") Then errorCell.ClearContents End If Exit Sub ErrHandler: lastErrorMsg = Err.Description End Sub ' obtain z1 master data, and update column E Private Sub Refresh(ws As Worksheet, ByVal startRow As Long, ByVal lastDataRow As Long) Dim z1Cache As Object: Set z1Cache = GetCache(CACHE_Z1) Application.EnableEvents = False On Error GoTo ErrorHandler Dim r As Long For r = startRow To lastDataRow Dim dVal As String: dVal = Trim(ws.Cells(r, 4).Value) ' Column D If dVal <> "" And z1Cache.Exists(dVal) Then 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 ErrorHandler: Application.EnableEvents = True Err.Raise ERR_CACHE_NOT_FOUND, "M1.Refresh", "Failed to refresh M1: " & Err.Description End Sub Private Sub ValidateWarn(ws As Worksheet, ByVal lastDataRow As Long) On Error GoTo ErrorHandler Dim exitMsg As String ' Get M2 sheet kukan code list directly Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig() Dim m2SheetConf As Object: Set m2SheetConf = sheetConfDict(CACHE_M2) Dim m2StartRow As Long: m2StartRow = m2SheetConf("StartRow") Dim wsM2 As Worksheet: Set wsM2 = ThisWorkbook.Worksheets(CACHE_M2) Dim lastRowM2 As Long: lastRowM2 = GetLastDataRowInRange(wsM2) If lastRowM2 < m2StartRow Then exitMsg = "M2 sheet has no data" GoTo ErrorHandler End If ' Build kukan code list from M2 sheet Dim kukanList As Object: Set kukanList = CreateObject("Scripting.Dictionary") Dim r As Long For r = m2StartRow To lastRowM2 Dim kukanCode As String: kukanCode = Trim(wsM2.Cells(r, 3).Value) If kukanCode <> "" And Not kukanList.Exists(kukanCode) Then kukanList.Add kukanCode, True End If Next r Dim sheetConf As Object: Set sheetConf = sheetConfDict("M1") Dim startRow As Long: startRow = sheetConf("StartRow") Dim errorCol As String: errorCol = sheetConf("ErrorCol") ' Check all rows in M1 sheet If lastDataRow < startRow Then exitMsg = "M1 sheet has no data" GoTo ErrorHandler End If Dim rowNum As Long For rowNum = startRow To lastDataRow Dim cValue As String: cValue = Trim(ws.Range("C" & rowNum).Value) If Not kukanList.Exists(cValue) Then ws.Cells(rowNum, errorCol).Value = GetErrorMsg("W001", cValue) ws.Range("C" & rowNum).Interior.Color = RGB(255, 128, 0) End If NextRow: Next rowNum Exit Sub ErrorHandler: If exitMsg <> "" Then MsgBox "ValidateWarn: " & exitMsg, vbExclamation Else MsgBox "ValidateWarn: " & Err.Description, vbExclamation End If End Sub