delete ninteiList and add optional button

This commit is contained in:
updsv7
2026-04-20 18:03:03 +09:00
parent 72566e3e03
commit 5c40eb4381
4 changed files with 7 additions and 63 deletions

View File

@@ -30,6 +30,10 @@ Sub Fit_Button()
Do_Fit ActiveSheet Do_Fit ActiveSheet
End Sub End Sub
Sub RefreshCache_Button()
' 重新加载所有缓存
End Sub
Private Sub DO_CSV_Import(ws As Excel.Worksheet) Private Sub DO_CSV_Import(ws As Excel.Worksheet)
On Error GoTo ImportError On Error GoTo ImportError

View File

@@ -30,7 +30,6 @@ Private oufukuList As Object
Private koutaiList As Object Private koutaiList As Object
Private higaitouList As Object Private higaitouList As Object
Private kenshuList As Object Private kenshuList As Object
Private ninteiKbnList As Object
Private sheetConfDict As Object Private sheetConfDict As Object
@@ -397,24 +396,6 @@ RefreshError:
Err.Raise 1001, "RefreshKenshuList", "Failed to load Enum lookup cache: " & Err.Description Err.Raise 1001, "RefreshKenshuList", "Failed to load Enum lookup cache: " & Err.Description
End Sub 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() Private Sub RefreshSheetDict()
Set sheetConfDict = CreateObject("Scripting.Dictionary") Set sheetConfDict = CreateObject("Scripting.Dictionary")
Dim sheetConf As Object Dim sheetConf As Object
@@ -656,8 +637,3 @@ Public Function GetKenshuList() As Object
If kenshuList Is Nothing Then Call RefreshKenshuList If kenshuList Is Nothing Then Call RefreshKenshuList
Set GetKenshuList = kenshuList Set GetKenshuList = kenshuList
End Function End Function
Public Function GetNinteiKbnList() As Object
If ninteiKbnList Is Nothing Then Call RefreshNinteiKbnList
Set GetNinteiKbnList = ninteiKbnList
End Function

View File

@@ -97,8 +97,6 @@ Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False Application.EnableEvents = False
On Error GoTo Finally On Error GoTo Finally
Call CreateNinteiDropdown(Target)
' === 3. rebuild dropdown list === ' === 3. rebuild dropdown list ===
Call RebuildDropdownsForTarget(Target) Call RebuildDropdownsForTarget(Target)
@@ -463,33 +461,6 @@ Private Sub CreateKenshuDropdown(ByVal rowNum As Long, ByVal idx As Long, ByVal
End With End With
End Sub 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 ' Create destination dropdown from M1_KukanD cache
' Structure: { D: { F: [G] } } ' Structure: { D: { F: [G] } }
Private Sub CreateToStationDropdown(ByVal rowNum As Long, ByVal transportCol As Long, ByVal stationFromCol As Long, ByVal stationToCol As Long) Private Sub CreateToStationDropdown(ByVal rowNum As Long, ByVal transportCol As Long, ByVal stationFromCol As Long, ByVal stationToCol As Long)
@@ -835,20 +806,13 @@ Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
Next kukanIdx Next kukanIdx
' Validate H, BB, BC columns ' Validate H, BB, BC columns
Dim ColH As String: ColH = "H" Dim linkCellValue As String: linkCellValue = Me.Cells(3, "H").Value
Dim ColBB As String: ColBB = "BB" Dim ColBB As String: ColBB = "BB"
Dim ColBC As String: ColBC = "BC" 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 valBB As String: valBB = Trim(Me.Cells(rowNum, ColBB).Value)
Dim valBC As String: valBC = Trim(Me.Cells(rowNum, ColBC).Value) Dim valBC As String: valBC = Trim(Me.Cells(rowNum, ColBC).Value)
Me.Range("H3").Interior.Color = vbWhite If linkCellValue = "1" Then
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 code = "1", BB and BC must be empty
If valBB <> "" Then If valBB <> "" Then
Me.Cells(rowNum, errorCol).Value = ColBB & " column must be empty" Me.Cells(rowNum, errorCol).Value = ColBB & " column must be empty"
@@ -860,7 +824,7 @@ Public Sub Validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As
Me.Range(ColBC & rowNum).Interior.Color = RGB(255, 0, 0) Me.Range(ColBC & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
End If End If
ElseIf codeH = "2" Then ElseIf linkCellValue = "2" Then
' If code = "2", BB and BC must have value ' If code = "2", BB and BC must have value
If valBB = "" Then If valBB = "" Then
Me.Cells(rowNum, errorCol).Value = ColBB & " column is required" Me.Cells(rowNum, errorCol).Value = ColBB & " column is required"