updsv7/vba
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

update C1

Browse Source
This commit is contained in:
updsv7
2026-04-17 12:30:18 +09:00
parent 0ef1b45031
commit 8b894ada0a
5 changed files with 63 additions and 84 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
src/module/Global_Cache.bas
View File

@@ -126,7 +126,7 @@ Public Sub RefreshM2Cache()
Dim kukanCode As String: kukanCode = Trim(wsM2.Cells(r, 3).Value) ' C column Dim kukanCode As String: kukanCode = Trim(wsM2.Cells(r, 3).Value) ' C column
Dim kanshu As String: kanshu = Trim(wsM2.Cells(r, 9).Value) ' I column Dim kanshu As String: kanshu = Trim(wsM2.Cells(r, 9).Value) ' I column
Dim code As String: code = Trim(wsM2.Cells(r, 10).Value) ' J column Dim code As String: code = Trim(wsM2.Cells(r, 10).Value) ' J column
Dim kValue As String: kValue = Trim(wsM2.Cells(r, 11).Value) ' K column Dim name As String: name = Trim(wsM2.Cells(r, 11).Value) ' K column
If kukanCode = "" Or kanshu = "" Or code = "" Then GoTo NextRow If kukanCode = "" Or kanshu = "" Or code = "" Then GoTo NextRow
@@ -143,10 +143,10 @@ Public Sub RefreshM2Cache()
innerDict.Add kanshu, innermostDict innerDict.Add kanshu, innermostDict
End If End If
' Inner level: code -> kValue ' Inner level: code -> name
Set innermostDict = innerDict(kanshu) Set innermostDict = innerDict(kanshu)
If Not innermostDict.Exists(code) Then If Not innermostDict.Exists(code) Then
innermostDict.Add code, kValue innermostDict.Add code, name
End If End If
NextRow: NextRow:

5
src/module/Module_Common.bas
View File

@@ -237,3 +237,8 @@ Sub AutoFitColumnWidth(ByVal fitColumnStart As Long, ByVal fitColumnEnd As Long)
ws.Range(ws.Columns(fitColumnStart), ws.Columns(fitColumnEnd)).AutoFit ws.Range(ws.Columns(fitColumnStart), ws.Columns(fitColumnEnd)).AutoFit
End If End If
End Sub End Sub
' Format: code:value (no space around colon)
Function MakeSelect(ByVal code As String, ByVal value As String) As String
MakeSelect = Trim(code) & ":" & Trim(value)
End Function

134
src/thisWorkbook/Tukin_C1.bas
View File

@@ -87,12 +87,12 @@ Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range Dim cell As Range
For Each cell In Target For Each cell In Target
If Trim(cell.Value) = "" Then If Trim(cell.Value) = "" Then
Call ClearRowData(Me, cell.Row) Call ClearRowData(cell.Row)
Else Else
Call FillAddressFromO1(cell.Row) Call FillAddressFromO1(cell.Row)
Dim i As Long Dim i As Long
For i = 0 To 3 For i = 0 To 3
Call CreateZ1TransportDropdown(Me, cell.Row, KUKAN_TRANSPORT_COLS(i)) Call CreateZ1TransportDropdown(cell.Row, KUKAN_TRANSPORT_COLS(i))
Next i Next i
End If End If
Next Next
@@ -105,9 +105,9 @@ Private Sub Worksheet_Change(ByVal Target As Range)
Dim cellT As Range Dim cellT As Range
For Each cellT In Target For Each cellT In Target
If Trim(cellT.Value) <> "" Then If Trim(cellT.Value) <> "" Then
Call CreateZ1StationDropdown(Me, cellT.Row, KUKAN_TRANSPORT_COLS(idx), KUKAN_STATION_COLS(idx)) Call CreateZ1StationDropdown(cellT.Row, KUKAN_TRANSPORT_COLS(idx), KUKAN_STATION_COLS(idx))
Else Else
Call ClearKukanValidation(Me, cellT.Row, KUKAN_STATION_COLS(idx)) Call ClearKukanValidation(cellT.Row, KUKAN_STATION_COLS(idx))
End If End If
Next Next
End If End If
@@ -118,12 +118,15 @@ Private Sub Worksheet_Change(ByVal Target As Range)
Dim cellU As Range Dim cellU As Range
For Each cellU In Target For Each cellU In Target
If Trim(cellU.Value) <> "" Then If Trim(cellU.Value) <> "" Then
Call CreateM1KukanDDropdown(Me, cellU.Row, KUKAN_TRANSPORT_COLS(idx), KUKAN_STATION_COLS(idx), KUKAN_ARRIVAL_COLS(idx)) Call CreateM1KukanDDropdown(cellU.Row, KUKAN_TRANSPORT_COLS(idx), KUKAN_STATION_COLS(idx), KUKAN_ARRIVAL_COLS(idx))
If Me.Cells(cellU.Row, KUKAN_ARRIVAL_COLS(idx)).Validation.Formula1 = "" Then On Error Resume Next
Call ClearKukanValidation(Me, cellU.Row, KUKAN_ARRIVAL_COLS(idx)) Dim formula As String: formula = Me.Cells(cellU.Row, KUKAN_ARRIVAL_COLS(idx)).Validation.Formula1
On Error GoTo 0
If formula = "" Then
Call ClearKukanValidation(cellU.Row, KUKAN_ARRIVAL_COLS(idx))
End If End If
Else Else
Call ClearKukanValidation(Me, cellU.Row, KUKAN_ARRIVAL_COLS(idx)) Call ClearKukanValidation(cellU.Row, KUKAN_ARRIVAL_COLS(idx))
End If End If
Next Next
End If End If
@@ -134,13 +137,12 @@ Private Sub Worksheet_Change(ByVal Target As Range)
Dim cellK As Range Dim cellK As Range
For Each cellK In Target For Each cellK In Target
If Trim(cellK.Value) <> "" Then If Trim(cellK.Value) <> "" Then
Call CreateZ1TransportDropdown(Me, cellK.Row, KUKAN_TRANSPORT_COLS(idx)) Call CreateZ1TransportDropdown(cellK.Row, KUKAN_TRANSPORT_COLS(idx))
If Me.Cells(cellK.Row, KUKAN_TRANSPORT_COLS(idx)).Validation.Formula1 <> "" Then If Me.Cells(cellK.Row, KUKAN_TRANSPORT_COLS(idx)).Validation.Formula1 <> "" Then
Call FillKukanFromM1(Me, cellK.Row, KUKAN_CODE_COLS(idx), Array(KUKAN_TRANSPORT_COLS(idx), KUKAN_STATION_COLS(idx), KUKAN_ARRIVAL_COLS(idx))) Call FillKukanFromM1(cellK.Row, KUKAN_CODE_COLS(idx), Array(KUKAN_TRANSPORT_COLS(idx), KUKAN_STATION_COLS(idx), KUKAN_ARRIVAL_COLS(idx)))
Call CreateM2Dropdown(Me, cellK.Row, KUKAN_CODE_COLS(idx), KUKAN_TICKET_COLS(idx))
End If End If
Else Else
Call ClearKukanValidation(Me, cellK.Row, KUKAN_TICKET_COLS(idx)) Call ClearKukanValidation(cellK.Row, KUKAN_TICKET_COLS(idx))
End If End If
Next Next
End If End If
@@ -150,65 +152,35 @@ Private Sub Worksheet_Change(ByVal Target As Range)
If idx >= 0 Then If idx >= 0 Then
Dim cellTi As Range Dim cellTi As Range
For Each cellTi In Target For Each cellTi In Target
' Clear old code first
Dim code2Col As Long: code2Col = KUKAN_CODE2_COLS(idx)
Me.Cells(cellTi.Row, code2Col).ClearContents
If Trim(cellTi.Value) <> "" Then If Trim(cellTi.Value) <> "" Then
Call CreateM2CodeDropdown(Me, cellTi.Row, KUKAN_CODE_COLS(idx), KUKAN_TICKET_COLS(idx), KUKAN_CODE2_COLS(idx)) Call CreateM2CodeDropdown(cellTi.Row, KUKAN_CODE_COLS(idx), KUKAN_TICKET_COLS(idx), code2Col)
Else Else
Call ClearKukanValidation(Me, cellTi.Row, KUKAN_CODE2_COLS(idx)) Call ClearKukanValidation(cellTi.Row, code2Col)
End If End If
Next Next
End If End If
End Sub End Sub
' Fill kukan info from M1 cache (key: kukan code, value: 7 elements) ' Fill kukan info from M1 cache (key: kukan code, value: 7 elements)
Private Sub FillKukanFromM1(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal codeCol As Long, ByVal fillCols As Variant) Private Sub FillKukanFromM1(ByVal rowNum As Long, ByVal codeCol As Long, ByVal fillCols As Variant)
If m1Cache Is Nothing Then Call RefreshM1Cache If m1Cache Is Nothing Then Call RefreshM1Cache
Dim code As String: code = Trim(ws.Cells(rowNum, codeCol).Value) Dim code As String: code = Trim(Me.Cells(rowNum, codeCol).Value)
If code = "" Then Exit Sub If code = "" Then Exit Sub
If m1Cache.Exists(code) Then If m1Cache.Exists(code) Then
Dim vals As Variant: vals = m1Cache(code) Dim vals As Variant: vals = m1Cache(code)
' value(1):value(2) -> fillCols(0) ' value(1):value(2) -> fillCols(0)
ws.Cells(rowNum, fillCols(0)).Value = Trim(vals(1)) & ": " & Trim(vals(2)) Me.Cells(rowNum, fillCols(0)).Value = MakeSelect(vals(1), vals(2))
' value(3) -> fillCols(1) ' value(3) -> fillCols(1)
ws.Cells(rowNum, fillCols(1)).Value = Trim(vals(3)) Me.Cells(rowNum, fillCols(1)).Value = Trim(vals(3))
' value(4) -> fillCols(2) ' value(4) -> fillCols(2)
ws.Cells(rowNum, fillCols(2)).Value = Trim(vals(4)) Me.Cells(rowNum, fillCols(2)).Value = Trim(vals(4))
Else Else
ws.Cells(rowNum, codeCol).ClearContents Me.Cells(rowNum, codeCol).ClearContents
End If
End Sub
' Create dropdown from M2 cache for ticket type column
Private Sub CreateM2Dropdown(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal kukanCodeCol As Long, ByVal ticketCol As Long)
If m2Cache Is Nothing Then Call RefreshM2Cache
Dim kukanCode As String: kukanCode = Trim(ws.Cells(rowNum, kukanCodeCol).Value)
If kukanCode = "" Then Exit Sub
' Build dropdown list: get all kanshu (券種) for the kukanCode
Dim dropdownList As String
If m2Cache.Exists(kukanCode) Then
Dim innerDict As Object: Set innerDict = m2Cache(kukanCode)
Dim kanshu As Variant
For Each kanshu In innerDict.Keys
If dropdownList = "" Then
dropdownList = kanshu
Else
dropdownList = dropdownList & "," & kanshu
End If
Next kanshu
End If
If dropdownList <> "" Then
With ws.Range(ws.Cells(rowNum, ticketCol).Address).Validation
.Delete
.Add Type:=xlValidateList, Formula1:=dropdownList
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.InputMessage = ""
End With
End If End If
End Sub End Sub
@@ -249,22 +221,24 @@ Private Sub FillAddressFromO1(ByVal rowNum As Long)
End Sub End Sub
' Create transport (T) dropdown from Z1 cache ' Create transport (T) dropdown from Z1 cache
Private Sub CreateZ1TransportDropdown(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal col As Long) Private Sub CreateZ1TransportDropdown(ByVal rowNum As Long, ByVal col As Long)
If z1Cache Is Nothing Then Call RefreshZ1Cache If z1Cache Is Nothing Then Call RefreshZ1Cache
' Build dropdown list from Z1 cache keys ' Build dropdown list: 区分:交通機関名称
Dim dropdownList As String Dim dropdownList As String
Dim key As Variant Dim key As Variant
For Each key In z1Cache.Keys For Each key In z1Cache.Keys
Dim displayText As String
displayText = MakeSelect(key, z1Cache(key)(0))
If dropdownList = "" Then If dropdownList = "" Then
dropdownList = key dropdownList = displayText
Else Else
dropdownList = dropdownList & "," & key dropdownList = dropdownList & "," & displayText
End If End If
Next key Next key
If dropdownList <> "" Then If dropdownList <> "" Then
With ws.Cells(rowNum, col).Validation With Me.Cells(rowNum, col).Validation
.Delete .Delete
.Add Type:=xlValidateList, Formula1:=dropdownList .Add Type:=xlValidateList, Formula1:=dropdownList
.IgnoreBlank = True .IgnoreBlank = True
@@ -276,10 +250,10 @@ Private Sub CreateZ1TransportDropdown(ByVal ws As Worksheet, ByVal rowNum As Lon
End Sub End Sub
' Create station (利用区間発) dropdown from M1_KukanD cache ' Create station (利用区間発) dropdown from M1_KukanD cache
Private Sub CreateZ1StationDropdown(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal transportCol As Long, ByVal stationCol As Long) Private Sub CreateZ1StationDropdown(ByVal rowNum As Long, ByVal transportCol As Long, ByVal stationCol As Long)
If m1KukanDCache Is Nothing Then Call RefreshM1KukanDCache If m1KukanDCache Is Nothing Then Call RefreshM1KukanDCache
Dim transport As String: transport = Trim(ws.Cells(rowNum, transportCol).Value) Dim transport As String: transport = Trim(Me.Cells(rowNum, transportCol).Value)
If transport = "" Then Exit Sub If transport = "" Then Exit Sub
' Build dropdown list from M1_KukanD cache: get all F values for the transport (D) ' Build dropdown list from M1_KukanD cache: get all F values for the transport (D)
@@ -297,7 +271,7 @@ Private Sub CreateZ1StationDropdown(ByVal ws As Worksheet, ByVal rowNum As Long,
End If End If
If dropdownList <> "" Then If dropdownList <> "" Then
With ws.Cells(rowNum, stationCol).Validation With Me.Cells(rowNum, stationCol).Validation
.Delete .Delete
.Add Type:=xlValidateList, Formula1:=dropdownList .Add Type:=xlValidateList, Formula1:=dropdownList
.IgnoreBlank = True .IgnoreBlank = True
@@ -308,11 +282,11 @@ 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 CreateM1KukanDDropdown(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal transportCol As Long, ByVal stationFromCol As Long, ByVal stationToCol As Long) Private Sub CreateM1KukanDDropdown(ByVal rowNum As Long, ByVal transportCol As Long, ByVal stationFromCol As Long, ByVal stationToCol As Long)
If m1KukanDCache Is Nothing Then Call RefreshM1KukanDCache If m1KukanDCache Is Nothing Then Call RefreshM1KukanDCache
Dim transport As String: transport = Trim(ws.Cells(rowNum, transportCol).Value) Dim transport As String: transport = Trim(Me.Cells(rowNum, transportCol).Value)
Dim stationFrom As String: stationFrom = Trim(ws.Cells(rowNum, stationFromCol).Value) Dim stationFrom As String: stationFrom = Trim(Me.Cells(rowNum, stationFromCol).Value)
If transport = "" Or stationFrom = "" Then Exit Sub If transport = "" Or stationFrom = "" Then Exit Sub
' Build dropdown list from M1_KukanD cache ' Build dropdown list from M1_KukanD cache
@@ -333,7 +307,7 @@ Private Sub CreateM1KukanDDropdown(ByVal ws As Worksheet, ByVal rowNum As Long,
End If End If
If dropdownList <> "" Then If dropdownList <> "" Then
With ws.Cells(rowNum, stationToCol).Validation With Me.Cells(rowNum, stationToCol).Validation
.Delete .Delete
.Add Type:=xlValidateList, Formula1:=dropdownList .Add Type:=xlValidateList, Formula1:=dropdownList
.IgnoreBlank = True .IgnoreBlank = True
@@ -343,16 +317,16 @@ Private Sub CreateM1KukanDDropdown(ByVal ws As Worksheet, ByVal rowNum As Long,
End Sub End Sub
' Clear validation for kukan columns ' Clear validation for kukan columns
Private Sub ClearKukanValidation(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal col As Long) Private Sub ClearKukanValidation(ByVal rowNum As Long, ByVal col As Long)
ws.Cells(rowNum, col).Validation.Delete Me.Cells(rowNum, col).Validation.Delete
End Sub End Sub
' Create dropdown from M2 cache: get code (J列) list for kukanCode + kanshu ' Create dropdown from M2 cache: get code (J列) list for kukanCode + kanshu
Private Sub CreateM2CodeDropdown(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal kukanCodeCol As Long, ByVal kanshuCol As Long, ByVal codeCol As Long) Private Sub CreateM2CodeDropdown(ByVal rowNum As Long, ByVal kukanCodeCol As Long, ByVal kanshuCol As Long, ByVal codeCol As Long)
If m2Cache Is Nothing Then Call RefreshM2Cache If m2Cache Is Nothing Then Call RefreshM2Cache
Dim kukanCode As String: kukanCode = Trim(ws.Cells(rowNum, kukanCodeCol).Value) Dim kukanCode As String: kukanCode = Trim(Me.Cells(rowNum, kukanCodeCol).Value)
Dim kanshu As String: kanshu = Trim(ws.Cells(rowNum, kanshuCol).Value) Dim kanshu As String: kanshu = Trim(Me.Cells(rowNum, kanshuCol).Value)
If kukanCode = "" Or kanshu = "" Then Exit Sub If kukanCode = "" Or kanshu = "" Then Exit Sub
' Build dropdown list: get all code for kukanCode + kanshu ' Build dropdown list: get all code for kukanCode + kanshu
@@ -364,7 +338,7 @@ Private Sub CreateM2CodeDropdown(ByVal ws As Worksheet, ByVal rowNum As Long, By
Dim code As Variant Dim code As Variant
For Each code In innermostDict.Keys For Each code In innermostDict.Keys
If dropdownList = "" Then If dropdownList = "" Then
dropdownList = code dropdownList = MakeSelect(code, innermostDict(code))
Else Else
dropdownList = dropdownList & "," & code dropdownList = dropdownList & "," & code
End If End If
@@ -373,7 +347,7 @@ Private Sub CreateM2CodeDropdown(ByVal ws As Worksheet, ByVal rowNum As Long, By
End If End If
If dropdownList <> "" Then If dropdownList <> "" Then
With ws.Cells(rowNum, codeCol).Validation With Me.Cells(rowNum, codeCol).Validation
.Delete .Delete
.Add Type:=xlValidateList, Formula1:=dropdownList .Add Type:=xlValidateList, Formula1:=dropdownList
.IgnoreBlank = True .IgnoreBlank = True
@@ -382,9 +356,9 @@ Private Sub CreateM2CodeDropdown(ByVal ws As Worksheet, ByVal rowNum As Long, By
End If End If
End Sub End Sub
' Clear row data ' Clear row data
Private Sub ClearRowData(ByVal ws As Worksheet, ByVal rowNum As Long) Private Sub ClearRowData(ByVal rowNum As Long)
ws.Range(ws.Cells(rowNum, 4), ws.Cells(rowNum, END_COL)).ClearContents Me.Range(Me.Cells(rowNum, 4), Me.Cells(rowNum, END_COL)).ClearContents
ws.Cells(rowNum, ERROR_COL).ClearContents Me.Cells(rowNum, ERROR_COL).ClearContents
End Sub End Sub
' ====== Button Macros ====== ' ====== Button Macros ======
@@ -413,21 +387,21 @@ Private Sub Validate(ByVal rowNum As Long)
Set ws = Me Set ws = Me
' Clear background color ' Clear background color
ws.Range(ws.Cells(rowNum, START_COL), ws.Cells(rowNum, END_COL)).Interior.Color = vbWhite Me.Range(Me.Cells(rowNum, START_COL), Me.Cells(rowNum, END_COL)).Interior.Color = vbWhite
' Required columns: C-G, K-N, AW ' Required columns: C-G, K-N, AW
Dim requiredCols As Variant Dim requiredCols As Variant
requiredCols = Array("C", "D", "E", "F", "G", "K", "L", "M", "N", "AW") requiredCols = Array("C", "D", "E", "F", "G", "K", "L", "M", "N", "AW")
Dim col As Variant Dim col As Variant
For Each col In requiredCols For Each col In requiredCols
If Trim(ws.Range(col & rowNum).Value & "") = "" Then If Trim(Me.Range(col & rowNum).Value & "") = "" Then
ws.Cells(rowNum, ERROR_COL).Value = col & " column is required" Me.Cells(rowNum, ERROR_COL).Value = col & " column is required"
ws.Range(col & rowNum).Interior.Color = RGB(255, 0, 0) Me.Range(col & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub Exit Sub
End If End If
Next col Next col
ws.Cells(rowNum, ERROR_COL).ClearContents Me.Cells(rowNum, ERROR_COL).ClearContents
End Sub End Sub
Sub C1_SortDataRowsByC() Sub C1_SortDataRowsByC()

2
src/thisWorkbook/Tukin_Cache_Mapping.md
View File

@@ -15,7 +15,7 @@
### m2Cache ### m2Cache
|列|C列|I列|J列|K列| |列|C列|I列|J列|K列|
|--------|--------|--------|--------|--------| |--------|--------|--------|--------|--------|
|ヘッダ|区間コード|券種|コード|1箇月運賃| |ヘッダ|区間コード|券種|コード|名称|
### z1Cache (222)交通機関マスタ ### z1Cache (222)交通機関マスタ
|列|C列|D列| |列|C列|D列|

BIN
通勤手当テンプレート_案.xlsm
View File

Binary file not shown.