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

next version

Browse Source
This commit is contained in:
updsv7
2026-04-18 21:42:00 +09:00
parent 7c487cba0b
commit 4a1be61150
26 changed files with 1101 additions and 769 deletions
Download Patch File Download Diff File Expand all files Collapse all files

521
src/sheet/C1.cls Normal file
View File

@@ -0,0 +1,521 @@
' ============================================================
' Module Name: Tukin_C1
' Module Desc: Commuter allowance editing sheet (no CSV import)
' Module Methods:
' - Tukin_ValidateRow
' - FillTransportFromM1KukanD
' - FillDepartureFromM1KukanD
' - FillArrivalFromM1KukanD
' - FillKukanFromM1
' - FillKanshuFromM2
' - FillCodeFromM2
' - FillAddressFromO1
' - FillZ1Dropdown
' ============================================================
' ====== (Tukin_C1) =======
' Commuter allowance editing sheet
' No CSV import - direct editing only
' ====== Constants ======
Const START_COL As Long = 3 ' C column (职员番号)
Const END_COL As Long = 56 ' BC column
Const ERROR_COL As Long = 57 ' BD column
Const Tukin_HEADER_ROW As Long = 6
' Column regions (for reference)
' D-H: 届出情報 (cols 4-8)
' I-J: 住所情報 (cols 9-10)
' K-O: 出勤情報 (cols 11-15)
' P-R: 自動車等情報 (cols 16-18)
' S-Y: 区間１情報 (cols 19-25)
' Z-AF: 区間２情報 (cols 26-32)
' AG-AM: 区間３情報 (cols 33-39)
' AN-AT: 区間４情報 (cols 40-46)
' AU-AX: 決定事項情報 (cols 47-50)
' AY-BA: 備考情報 (cols 51-53)
' BB-BC: 認定情報 (cols 54-56)
' ============================================================
' Column arrays for 4 kukan sections
' ============================================================
Private Function KUKAN_CODE_COLS() As Variant
KUKAN_CODE_COLS = Array(19, 26, 33, 40) ' S, Z, AG, AN
End Function
Private Function KUKAN_TRANSPORT_COLS() As Variant
KUKAN_TRANSPORT_COLS = Array(20, 27, 34, 41) ' T, AA, AH, AO
End Function
Private Function KUKAN_STATION_COLS() As Variant
KUKAN_STATION_COLS = Array(21, 28, 35, 42) ' U, AB, AI, AP
End Function
Private Function KUKAN_ARRIVAL_COLS() As Variant
KUKAN_ARRIVAL_COLS = Array(22, 29, 36, 43) ' V, AC, AJ, AQ
End Function
Private Function KUKAN_TICKET_COLS() As Variant
KUKAN_TICKET_COLS = Array(23, 30, 37, 44) ' W, AD, AK, AR
End Function
Private Function KUKAN_CODE2_COLS() As Variant
KUKAN_CODE2_COLS = Array(24, 31, 38, 45) ' X, AE, AL, AS
End Function
Private Function KUKAN_START_DAY_COLS() As Variant
KUKAN_START_DAY_COLS = Array(25, 32, 39, 46) ' Y, AF, AM, AT
End Function
Private Function DATE_COLS() As Variant
DATE_COLS = Array(4, 5, 6, 25, 32, 39, 46, 54) ' D, E, F, Y, AF, AM, AT, BB
End Function
' ============================================================
' Helper: Get index by value, return -1 if not found
' ============================================================
Private Function GetIdx(val As Long, arr As Variant) As Long
Dim i As Long
For i = LBound(arr) To UBound(arr)
If arr(i) = val Then
GetIdx = i
Exit Function
End If
Next i
GetIdx = -1
End Function
' ============================================================
' Event Handlers
' ============================================================
Private Sub Worksheet_Change(ByVal Target As Range)
Dim watchArea As Range
With Me
Set watchArea = Union( _
.Columns("C"), _
.Columns("D"), _
.Columns("E"), _
.Columns("F"), _
.Columns("G"), _
.Columns("I"), _
.Columns("S:W"), _
.Columns("Z:AD"), _
.Columns("AG:AK"), _
.Columns("AN:AR"), _
.Columns("BB") _
)
End With
Dim intersectRng As Range: Set intersectRng = Application.Intersect(Target, watchArea)
If intersectRng Is Nothing Then Exit Sub
If Target.Row < 7 Then Exit Sub
Application.EnableEvents = False
On Error GoTo Finally
' === 3. rebuild dropdown list ===
Call RebuildDropdownsForTarget(Target)
' === Column C changes ===
If Target.Column = 3 Then
Dim cell As Range
For Each cell In Target
If Trim(cell.Value) = "" Then
Call ClearRowData(cell.Row)
Else
Call FillAddressFromO1(cell.Row)
End If
Next
End If
' === Date columns changes ===
idx = GetIdx(Target.Column, DATE_COLS)
If idx >= 0 Then
Dim cellDate As Range
For Each cellDate In Target
If Trim(cellDate.Value) <> "" Then
cellDate.Value = FormatDateInput(cellDate.Value)
End If
Next
End If
' === Transport column changes (T, AA, AH, AO) ===
Dim idx As Long
idx = GetIdx(Target.Column, KUKAN_TRANSPORT_COLS)
If idx >= 0 Then
Dim cellT As Range
For Each cellT In Target
Me.Cells(cellT.Row, KUKAN_STATION_COLS(idx)).ClearContents
Me.Cells(cellT.Row, KUKAN_ARRIVAL_COLS(idx)).ClearContents
If Trim(cellT.Value) <> "" Then
Call CreateFromStationDropdown(cellT.Row, KUKAN_TRANSPORT_COLS(idx), KUKAN_STATION_COLS(idx))
End If
Next
End If
' === Station column changes (U, AB, AI, AP) ===
idx = GetIdx(Target.Column, KUKAN_STATION_COLS)
If idx >= 0 Then
Dim cellU As Range
For Each cellU In Target
' Clear arrival value first
Me.Cells(cellU.Row, KUKAN_ARRIVAL_COLS(idx)).ClearContents
If Trim(cellU.Value) <> "" Then
Call CreateToStationDropdown(cellU.Row, KUKAN_TRANSPORT_COLS(idx), KUKAN_STATION_COLS(idx), KUKAN_ARRIVAL_COLS(idx))
End If
Next
End If
' === Arrival column changes (V, AC, AJ, AQ) ===
idx = GetIdx(Target.Column, KUKAN_ARRIVAL_COLS)
If idx >= 0 Then
Dim cellV As Range
For Each cellV In Target
If Trim(cellV.Value) <> "" Then
' Reverse lookup: find kukan code by transport + from + to
Dim foundCode As String
foundCode = FindKukanCodeByStation(cellV.Row, KUKAN_TRANSPORT_COLS(idx), KUKAN_STATION_COLS(idx), KUKAN_ARRIVAL_COLS(idx))
If foundCode <> "" Then
Me.Cells(cellV.Row, KUKAN_CODE_COLS(idx)).Value = foundCode
End If
End If
Next
End If
' === Kukan code column changes (S, Z, AG, AN) ===
idx = GetIdx(Target.Column, KUKAN_CODE_COLS)
If idx >= 0 Then
Dim cellK As Range
For Each cellK In Target
Call FillKukanFromM1(cellK.Row, idx)
Next
End If
' === Ticket column changes (W, AD, AK, AR) ===
idx = GetIdx(Target.Column, KUKAN_TICKET_COLS)
If idx >= 0 Then
Dim cellTi As Range
For Each cellTi In Target
' Clear old code first
Dim code2Col As Long: code2Col = KUKAN_CODE2_COLS(idx)
Me.Cells(cellTi.Row, code2Col).ClearContents
Me.Cells(cellTi.Row, code2Col).Validation.Delete
If Not IsError(Application.Match(cellTi.Value, Array("1", "2", "3"), 0)) Then
Call CreateM2CodeDropdown(cellTi.Row, KUKAN_CODE_COLS(idx), KUKAN_TICKET_COLS(idx), code2Col)
End If
Next
End If
Finally:
Application.EnableEvents = True '
End Sub
Private Sub RebuildDropdownsForTarget(ByVal Target As Range)
If Target Is Nothing Then Exit Sub
Dim cell As Range
Dim processedRows As Object
Set processedRows = CreateObject("Scripting.Dictionary")
For Each cell In Target
Dim r As Long
r = cell.Row
If Not processedRows.Exists(r) Then
processedRows(r) = True
Dim colLetter As String
colLetter = Split(Me.Cells(1, cell.Column).Address(True, False), "$")(0)
Dim dropdowns As Variant
dropdowns = Array( _
Array("T", "BuildTransportList"), _
Array("AA", "BuildTransportList"), _
Array("AH", "BuildTransportList"), _
Array("AO", "BuildTransportList"), _
Array("G", "BuildTodokeList"), _
Array("M", "BuildOufukuList"), _
Array("N", "BuildKoutaiList"), _
Array("AU", "BuildKetteiList"), _
Array("AW", "BuildHigaitouList"), _
Array("AX", "BuildMonthAmountKbnList"), _
Array("BC", "BuildKanshokuList") _
)
Dim i As Long
For i = LBound(dropdowns) To UBound(dropdowns)
If colLetter <> dropdowns(i)(0) Then
With Me.Cells(r, dropdowns(i)(0)).Validation
.Delete
.Add Type:=xlValidateList, Formula1:=Application.Run(dropdowns(i)(1))
.IgnoreBlank = True
.InCellDropdown = True
End With
End If
Next i
End If
NextCell:
Next cell
End Sub
' Fill kukan info from M1 cache (key: kukan code, value: 7 elements)
Private Sub FillKukanFromM1(ByVal rowNum As Long, ByVal idx As Long)
If m1Cache Is Nothing Then Call RefreshM1Cache
Dim codeCol As Long: codeCol = KUKAN_CODE_COLS(idx)
Dim transportCol As Long: transportCol = KUKAN_TRANSPORT_COLS(idx)
Dim stationCol As Long: stationCol = KUKAN_STATION_COLS(idx)
Dim arrivalCol As Long: arrivalCol = KUKAN_ARRIVAL_COLS(idx)
Dim ticketCol As Long: ticketCol = KUKAN_TICKET_COLS(idx)
Dim code2Col As Long: code2Col = KUKAN_CODE2_COLS(idx)
Dim startDayCol As Long: startDayCol = KUKAN_START_DAY_COLS(idx)
Dim code As String: code = Trim(Me.Cells(rowNum, codeCol).Value)
If code <> "" And m1Cache.Exists(code) Then
Dim vals As Variant: vals = m1Cache(code)
Me.Cells(rowNum, transportCol).Value = MakeSelect(vals(1), vals(2))
Me.Cells(rowNum, stationCol).Value = Trim(vals(3))
Me.Cells(rowNum, arrivalCol).Value = Trim(vals(4))
Else
Me.Cells(rowNum, transportCol).ClearContents
Me.Cells(rowNum, stationCol).ClearContents
Me.Cells(rowNum, arrivalCol).ClearContents
Me.Cells(rowNum, ticketCol).ClearContents
Me.Cells(rowNum, code2Col).ClearContents
Me.Cells(rowNum, startDayCol).ClearContents
Call ClearKukanValidation(rowNum, stationCol)
Call ClearKukanValidation(rowNum, arrivalCol)
Call ClearKukanValidation(rowNum, code2Col)
End If
End Sub
' Fill address dropdown from O1 cache
Private Sub FillAddressFromO1(ByVal rowNum As Long)
If o1Cache Is Nothing Then Call RefreshO1Cache
Dim empNo As String
empNo = Trim(Me.Cells(rowNum, 3).Value)
If empNo = "" Then Exit Sub
' Build dropdown list from O1 cache: get all E values for the C
Dim dropdownList As String
If o1Cache.Exists(empNo) Then
Dim innerDict As Object
Set innerDict = o1Cache(empNo)
Dim eKey As Variant
For Each eKey In innerDict.Keys
If dropdownList = "" Then
dropdownList = eKey
Else
dropdownList = dropdownList & "," & eKey
End If
Next eKey
End If
' Create dropdown for I column (住所)
If dropdownList <> "" Then
With Me.Range("I" & rowNum).Validation
.Delete
.Add Type:=xlValidateList, Formula1:=dropdownList
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.InputMessage = ""
End With
End If
End Sub
' Create station (利用区間発) dropdown from M1_KukanD cache
Private Sub CreateFromStationDropdown(ByVal rowNum As Long, ByVal transportCol As Long, ByVal stationCol As Long)
If m1KukanDCache Is Nothing Then Call RefreshM1KukanDCache
Dim transport As String: transport = GetCode(Me.Cells(rowNum, transportCol).Value)
If transport = "" Then Exit Sub
' Build dropdown list from M1_KukanD cache: get all F values for the transport (D)
Dim dropdownList As String
If m1KukanDCache.Exists(transport) Then
Dim innerDict As Object: Set innerDict = m1KukanDCache(transport)
Dim fValue As Variant
For Each fValue In innerDict.Keys
If dropdownList = "" Then
dropdownList = fValue
Else
dropdownList = dropdownList & "," & fValue
End If
Next fValue
End If
If dropdownList <> "" Then
With Me.Cells(rowNum, stationCol).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)
If m1KukanDCache Is Nothing Then Call RefreshM1KukanDCache
Dim transport As String: transport = GetCode(Me.Cells(rowNum, transportCol).Value)
Dim stationFrom As String: stationFrom = GetCode(Me.Cells(rowNum, stationFromCol).Value)
If transport = "" Or stationFrom = "" Then Exit Sub
' Build dropdown list from M1_KukanD cache
Dim dropdownList As String
If m1KukanDCache.Exists(transport) Then
Dim innerDict As Object: Set innerDict = m1KukanDCache(transport)
If innerDict.Exists(stationFrom) Then
Dim arr As Object: Set arr = innerDict(stationFrom)
Dim gValue As Variant
For Each gValue In arr.Keys
If dropdownList = "" Then
dropdownList = gValue
Else
dropdownList = dropdownList & "," & gValue
End If
Next gValue
End If
End If
If dropdownList <> "" Then
With Me.Cells(rowNum, stationToCol).Validation
.Delete
.Add Type:=xlValidateList, Formula1:=dropdownList
.IgnoreBlank = True
.InCellDropdown = True
End With
End If
End Sub
' Find kukan code by transport + station_from + station_to (reverse lookup)
Private Function FindKukanCodeByStation(ByVal rowNum As Long, ByVal transportCol As Long, ByVal stationFromCol As Long, ByVal stationToCol As Long) As String
If m1Cache Is Nothing Then Call RefreshM1Cache
Dim transportKbn As String: transportKbn = GetCode(Trim(Me.Cells(rowNum, transportCol).Value))
Dim stationFrom As String: stationFrom = Trim(Me.Cells(rowNum, stationFromCol).Value)
Dim stationTo As String: stationTo = Trim(Me.Cells(rowNum, stationToCol).Value)
If transportKbn = "" Or stationFrom = "" Or stationTo = "" Then
FindKukanCodeByStation = ""
Exit Function
End If
Dim code As Variant
For Each code In m1Cache.Keys
Dim vals As Variant: vals = m1Cache(code)
' vals(1) = D列(交通機関区分), vals(3) = F列(発), vals(4) = G列(着)
If vals(1) = transportKbn And vals(3) = stationFrom And vals(4) = stationTo Then
FindKukanCodeByStation = code
Exit Function
End If
Next code
FindKukanCodeByStation = ""
End Function
' Clear validation for kukan columns
Private Sub ClearKukanValidation(ByVal rowNum As Long, ByVal col As Long)
Me.Cells(rowNum, col).Validation.Delete
End Sub
' Create dropdown from M2 cache: get code (J列) list for kukanCode + kanshu
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
Dim kukanCode As String: kukanCode = Trim(Me.Cells(rowNum, kukanCodeCol).Value)
Dim kanshu As String: kanshu = Trim(Me.Cells(rowNum, kanshuCol).Value)
If kukanCode = "" Or kanshu = "" Then Exit Sub
' Build dropdown list: get all code for kukanCode + kanshu
Dim dropdownList As String
If m2Cache.Exists(kukanCode) Then
Dim innerDict As Object: Set innerDict = m2Cache(kukanCode)
If innerDict.Exists(kanshu) Then
Dim innermostDict As Object: Set innermostDict = innerDict(kanshu)
Dim code As Variant
For Each code In innermostDict.Keys
If dropdownList = "" Then
dropdownList = MakeSelect(code, innermostDict(code))
Else
dropdownList = dropdownList & "," & code
End If
Next code
End If
End If
If dropdownList <> "" Then
With Me.Cells(rowNum, codeCol).Validation
.Delete
.Add Type:=xlValidateList, Formula1:=dropdownList
.IgnoreBlank = True
.InCellDropdown = True
End With
End If
End Sub
' Clear row data
Private Sub ClearRowData(ByVal rowNum As Long)
Me.Range(Me.Cells(rowNum, 4), Me.Cells(rowNum, END_COL)).ClearContents
Me.Cells(rowNum, ERROR_COL).ClearContents
End Sub
' ====== Button Macros ======
Private Sub validateButton()
Dim lastRow As Long, r As Long, errorCount As Long
lastRow = GetLastDataRowInRange(Me, START_COL, END_COL)
If lastRow < 7 Then
MsgBox "No data found.", vbExclamation
Exit Sub
End If
errorCount = 0
For r = 7 To lastRow
Call Validate(r)
If Trim(Cells(r, ERROR_COL).Value) <> "" Then
errorCount = errorCount + 1
End If
Next r
MsgBox "Validation complete. Errors: " & errorCount, vbInformation
End Sub
' Validation logic
Private Private Sub validate(ByVal rowNum As Long)
Set ws = Me
' Clear background color
Me.Range(Me.Cells(rowNum, START_COL), Me.Cells(rowNum, END_COL)).Interior.Color = vbWhite
' Required columns: C-G, K-N, AW
Dim requiredCols As Variant
requiredCols = Array("C", "D", "E", "F", "G", "K", "L", "M", "N", "AW")
Dim col As Variant
For Each col In requiredCols
If Trim(Me.Range(col & rowNum).Value & "") = "" Then
Me.Cells(rowNum, ERROR_COL).Value = col & " column is required"
Me.Range(col & rowNum).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
Next col
Me.Cells(rowNum, ERROR_COL).ClearContents
End Sub
Private Sub Do_Sort()
Call SortDataRows(3)
End Sub
Private Sub Do_Filter()
Call ToggleAutoFilter(START_COL, END_COL)
End Sub
Private Sub Do_Fit()
Call AutoFitColumnWidth(START_COL, END_COL)
End Sub