add ninteiList

This commit is contained in:
updsv7
2026-04-20 17:20:51 +09:00
parent 33f16bb248
commit 72566e3e03
4 changed files with 114 additions and 3 deletions

View File

@@ -82,6 +82,7 @@ Sub WriteCSVFromArray( _
' Escape double quotes: "" represents a single "
field = """" & Replace(field, """", """""") & """"
End If
field = GetCode(field)
fields(j - LBound(data, 2) + 1) = field
Next j

View File

@@ -30,6 +30,7 @@ Private oufukuList As Object
Private koutaiList As Object
Private higaitouList As Object
Private kenshuList As Object
Private ninteiKbnList As Object
Private sheetConfDict As Object
@@ -396,6 +397,24 @@ RefreshError:
Err.Raise 1001, "RefreshKenshuList", "Failed to load Enum lookup cache: " & Err.Description
End Sub
' ============================================================
' ninteiKbnList
' ============================================================
Private Sub RefreshNinteiKbnList()
On Error GoTo RefreshError
Set ninteiKbnList = LoadLookup("Enum", keyCol:=15, valueCols:=Array(16), startRow:=3)
On Error GoTo 0
If ninteiKbnList Is Nothing Or ninteiKbnList.Count = 0 Then
Err.Raise 1003, "RefreshNinteiKbnList", "Enum reference data is empty"
End If
Exit Sub
RefreshError:
Err.Raise 1001, "RefreshNinteiKbnList", "Failed to load Enum lookup cache: " & Err.Description
End Sub
Private Sub RefreshSheetDict()
Set sheetConfDict = CreateObject("Scripting.Dictionary")
Dim sheetConf As Object
@@ -411,8 +430,8 @@ Private Sub RefreshSheetDict()
sheetConf("RefreshCacheName") = ""
sheetConf("CSV_Encoding") = "shift_jis"
sheetConf("HasHeader") = True
sheetConf("ExpectedColumnCount") = 54
sheetConf("HeaderColumns") = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N")
sheetConf("ExpectedColumnCount") = 41
sheetConf("HeaderColumns") = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "W", "X", "Y", "Z", "AD", "AE", "AF", "AG", "AK", "AL", "AM", "AN", "AR", "AS", "AT", "AU", "AV", "AW", "AX", "AY", "AZ", "BA", "BB", "BC")
sheetConf("AlwaysQuote") = False
sheetConf("FilterRow") = 7
@@ -636,4 +655,9 @@ End Function
Public Function GetKenshuList() As Object
If kenshuList Is Nothing Then Call RefreshKenshuList
Set GetKenshuList = kenshuList
End Function
Public Function GetNinteiKbnList() As Object
If ninteiKbnList Is Nothing Then Call RefreshNinteiKbnList
Set GetNinteiKbnList = ninteiKbnList
End Function

View File

@@ -91,12 +91,14 @@ Private Sub Worksheet_Change(ByVal Target As Range)
Dim intersectRng As Range: Set intersectRng = Application.Intersect(Target, watchArea)
If intersectRng Is Nothing Then Exit Sub
If Target.Row < 7 Then Exit Sub
If Target.Row < 8 Then Exit Sub
Dim idx As Long
Application.EnableEvents = False
On Error GoTo Finally
Call CreateNinteiDropdown(Target)
' === 3. rebuild dropdown list ===
Call RebuildDropdownsForTarget(Target)
@@ -461,6 +463,33 @@ Private Sub CreateKenshuDropdown(ByVal rowNum As Long, ByVal idx As Long, ByVal
End With
End Sub
' Create Nintei dropdown from ninteiKbnList if H3 cell Validation does not exist
Private Sub CreateNinteiDropdown(ByVal Target As Range)
Dim ninteiKbnList As Object: Set ninteiKbnList = GetNinteiKbnList()
' Build dropdown list from ninteiKbnList
Dim dropdownList As String
Dim key As Variant
For Each key In ninteiKbnList.Keys
Dim displayText As String
displayText = MakeSelect(key, ninteiKbnList(key)(0))
If dropdownList = "" Then
dropdownList = displayText
Else
dropdownList = dropdownList & "," & displayText
End If
Next key
If dropdownList <> "" Then
With Me.Range("H3").Validation
.Delete
.Add Type:=xlValidateList, Formula1:=dropdownList
.IgnoreBlank = True
.InCellDropdown = True
End With
End If
End Sub
' Create destination dropdown from M1_KukanD cache
' Structure: { D: { F: [G] } }
Private Sub CreateToStationDropdown(ByVal rowNum As Long, ByVal transportCol As Long, ByVal stationFromCol As Long, ByVal stationToCol As Long)
@@ -788,5 +817,62 @@ Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
End If
Next kukanIdx
' Validate KUKAN_CODE_COLS for duplicates (non-empty only)
Dim kukanCodes As Object: Set kukanCodes = CreateObject("Scripting.Dictionary")
For kukanIdx = LBound(KUKAN_CODE_COLS) To UBound(KUKAN_CODE_COLS)
kukanCol = KUKAN_CODE_COLS(kukanIdx)
kukanCode = Trim(Me.Cells(rowNum, kukanCol).Value)
If kukanCode <> "" Then
If kukanCodes.Exists(kukanCode) Then
kukanLetter = Split(Me.Cells(1, kukanCol).Address, "$")(1)
Me.Cells(rowNum, errorCol).Value = kukanLetter & " column is duplicated"
Me.Range(kukanLetter & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
Else
kukanCodes.Add kukanCode, True
End If
End If
Next kukanIdx
' Validate H, BB, BC columns
Dim ColH As String: ColH = "H"
Dim ColBB As String: ColBB = "BB"
Dim ColBC As String: ColBC = "BC"
Dim codeH As String: codeH = GetCode(Trim(Me.Cells(3, ColH).Value))
Dim valBB As String: valBB = Trim(Me.Cells(rowNum, ColBB).Value)
Dim valBC As String: valBC = Trim(Me.Cells(rowNum, ColBC).Value)
Me.Range("H3").Interior.Color = vbWhite
If codeH = "" Then
MsgBox "Please select cell " & ColH & "3 column", vbExclamation
Me.Range("H3").Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
If codeH = "1" Then
' If code = "1", BB and BC must be empty
If valBB <> "" Then
Me.Cells(rowNum, errorCol).Value = ColBB & " column must be empty"
Me.Range(ColBB & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
If valBC <> "" Then
Me.Cells(rowNum, errorCol).Value = ColBC & " column must be empty"
Me.Range(ColBC & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
ElseIf codeH = "2" Then
' If code = "2", BB and BC must have value
If valBB = "" Then
Me.Cells(rowNum, errorCol).Value = ColBB & " column is required"
Me.Range(ColBB & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
If valBC = "" Then
Me.Cells(rowNum, errorCol).Value = ColBC & " column is required"
Me.Range(ColBC & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
End If
Me.Cells(rowNum, errorCol).ClearContents
End Sub