diff --git a/src/sh/tuk/init_module/ThisWorkbook.cls b/src/sh/tuk/init_module/ThisWorkbook.cls new file mode 100644 index 0000000..58f6132 --- /dev/null +++ b/src/sh/tuk/init_module/ThisWorkbook.cls @@ -0,0 +1,118 @@ +Option Explicit + +' Author: +' Date: + +Private Sub Workbook_Open() + + Dim ws As Worksheet + + Application.ScreenUpdating = False + Application.Calculation = xlCalculationManual + Application.EnableEvents = False + Application.DisplayAlerts = False + Application.StatusBar = False + + For Each ws In ThisWorkbook.Worksheets + ResizeShapes ws + PositionShapesInRow ws, "B3" + Next ws + + Application.ScreenUpdating = True + Application.Calculation = xlCalculationAutomatic + Application.EnableEvents = True + Application.DisplayAlerts = True + Application.StatusBar = True + +End Sub + +' Description: +' Resizes shapes by name category: +' load / filter / fit / sort -> square 23.95 x 23.95 +' output / input / check -> horizontal button 85.04 x 22.68 +' Parameters: +' ws: Target worksheet +' Author: +' Date: + +Private Sub ResizeShapes(ws As Worksheet) + + Dim shp As Shape + + For Each shp In ws.Shapes + If shp.name = "load" Or shp.name = "filter" Or shp.name = "fit" Or shp.name = "sort" Then + shp.LockAspectRatio = msoFalse + shp.Height = 23.95 + shp.Width = 23.95 + ElseIf shp.name = "output" Or shp.name = "input" Or shp.name = "check" Then + shp.LockAspectRatio = msoFalse + shp.Width = 85.0393700787 + shp.Height = 22.6771653543 + ElseIf shp.name = "confirm_no" Or shp.name = "confirm_yes" Then + shp.LockAspectRatio = msoFalse + shp.Height = 22.6771653543 + shp.Width = 56.68 + End If + Next shp + +End Sub + +' Description: +' Aligns and spaces shapes horizontally starting from a reference cell. +' The leftmost existing shape in the given order aligns to the ref cell's left edge. +' All shapes keep their original Y (vertical) position. +' Subsequent shapes are placed at (shape_icon_size / 2) intervals. +' Parameters: +' ws: Target worksheet +' refCellAddr: Reference cell address (e.g. "B3") +' Author: +' Date: + +Private Sub PositionShapesInRow(ws As Worksheet, refCellAddr As String) + + Const SHAPE_ORDER As String = "input,check,output,sort,filter,fit,load,confirm_no,confirm_yes" + Const GAP As Double = 11.975 + + Dim shapeOrder() As String + shapeOrder = Split(SHAPE_ORDER, ",") + + Dim refCell As Range + Set refCell = ws.Range(refCellAddr) + Dim refLeft As Double + refLeft = refCell.Left + + Dim baseY As Double + baseY = 0 + + Dim shapeName As Variant + Dim targetShape As Shape + Dim prevShape As Shape + Dim isFirst As Boolean + Dim i As Long + + isFirst = True + + For i = LBound(shapeOrder) To UBound(shapeOrder) + shapeName = shapeOrder(i) + + Set targetShape = Nothing + On Error Resume Next + Set targetShape = ws.Shapes(CStr(shapeName)) + On Error GoTo 0 + + If targetShape Is Nothing Then GoTo NextShape + + If isFirst Then + targetShape.Left = refLeft + baseY = targetShape.Top + isFirst = False + Else + targetShape.Left = prevShape.Left + prevShape.Width + GAP + targetShape.Top = baseY + End If + + Set prevShape = targetShape +NextShape: + Next i + +End Sub diff --git a/src/sh/tuk/module/Common_Global_Cache.bas b/src/sh/tuk/module/Common_Global_Cache.bas index 3cadc1a..33b57b1 100644 --- a/src/sh/tuk/module/Common_Global_Cache.bas +++ b/src/sh/tuk/module/Common_Global_Cache.bas @@ -21,6 +21,7 @@ Public Const CACHE_O2 As String = "O2" Public Const CACHE_O3 As String = "O3" Public Const CACHE_M1 As String = "M1" Public Const CACHE_M2 As String = "M2" +Private Const O1_BLOCK_SIZE As Long = 100 Private sheetConfDict As Object @@ -751,6 +752,101 @@ Public Sub WriteCachesSheet(ByVal cacheName As String) FormulaCache(cacheName) = formulaStr End Sub +' ============================================================ +' O1 Address Dropdown Cache Writers +' Per-row address1/address2 unique values are written to Caches sheet +' so xlValidateList Formula1 references Text-formatted cells. +' This bypasses Excel's date/number auto-coercion that happens when +' comma-separated Formula1 strings contain values like "2623-41". +' +' Layout: +' Caches column N (14) = O1 address1 data +' Caches column O (15) = O1 address2 data +' Block per C1 row: rows (rowNum-1)*O1_BLOCK_SIZE+1 to rowNum*O1_BLOCK_SIZE +' ============================================================ + +' Write O1 address1 unique values for cshainno into Caches col N block. +' Returns Formula1 like "=Caches!$N$X:$N$Y", or "" if no data. +Public Function WriteCachesSheetForO1Address1(ByVal cshainno As String, ByVal rowNum As Long) As String + Dim wsCache As Worksheet + Set wsCache = ThisWorkbook.Sheets("Caches") + If wsCache Is Nothing Then + Set wsCache = ThisWorkbook.Sheets.Add + wsCache.Name = "Caches" + wsCache.Visible = xlVeryHidden + End If + + Const COL As Long = 14 ' N column + Dim blockStart As Long: blockStart = (rowNum - 1) * O1_BLOCK_SIZE + 1 + Dim blockEnd As Long: blockEnd = blockStart + O1_BLOCK_SIZE - 1 + + ' Clear block to prevent stale data leakage across rows + wsCache.Range(wsCache.Cells(blockStart, COL), wsCache.Cells(blockEnd, COL)).ClearContents + + Dim o1Cache As Object: Set o1Cache = GetCache(CACHE_O1) + If o1Cache Is Nothing Then Exit Function + If Not o1Cache.Exists(cshainno) Then Exit Function + + Dim innerDict As Object: Set innerDict = o1Cache(cshainno) + + Dim idx As Long: idx = 0 + Dim eKey As Variant + For Each eKey In innerDict.Keys + idx = idx + 1 + With wsCache.Cells(blockStart + idx, COL) + .NumberFormat = "@" + .Value = CStr(eKey) + End With + If idx >= O1_BLOCK_SIZE Then Exit For + Next eKey + + If idx = 0 Then Exit Function + + WriteCachesSheetForO1Address1 = "=Caches!$N$" & (blockStart + 1) & ":$N$" & (blockStart + idx) +End Function + +' Write O1 address2 unique values for (cshainno, address1) into Caches col O block. +' Returns Formula1 like "=Caches!$O$X:$O$Y", or "" if no data. +Public Function WriteCachesSheetForO1Address2(ByVal cshainno As String, ByVal address1 As String, ByVal rowNum As Long) As String + Dim wsCache As Worksheet + Set wsCache = ThisWorkbook.Sheets("Caches") + If wsCache Is Nothing Then + Set wsCache = ThisWorkbook.Sheets.Add + wsCache.Name = "Caches" + wsCache.Visible = xlVeryHidden + End If + + Const COL As Long = 15 ' O column + Dim blockStart As Long: blockStart = (rowNum - 1) * O1_BLOCK_SIZE + 1 + Dim blockEnd As Long: blockEnd = blockStart + O1_BLOCK_SIZE - 1 + + wsCache.Range(wsCache.Cells(blockStart, COL), wsCache.Cells(blockEnd, COL)).ClearContents + + Dim o1Cache As Object: Set o1Cache = GetCache(CACHE_O1) + If o1Cache Is Nothing Then Exit Function + If Not o1Cache.Exists(cshainno) Then Exit Function + + Dim innerDict As Object: Set innerDict = o1Cache(cshainno) + If Not innerDict.Exists(address1) Then Exit Function + + Dim addr2Dict As Object: Set addr2Dict = innerDict(address1) + + Dim idx As Long: idx = 0 + Dim addr2Key As Variant + For Each addr2Key In addr2Dict.Keys + idx = idx + 1 + With wsCache.Cells(blockStart + idx, COL) + .NumberFormat = "@" + .Value = CStr(addr2Key) + End With + If idx >= O1_BLOCK_SIZE Then Exit For + Next addr2Key + + If idx = 0 Then Exit Function + + WriteCachesSheetForO1Address2 = "=Caches!$O$" & (blockStart + 1) & ":$O$" & (blockStart + idx) +End Function + Public Function GetValidationFormula(ByVal cacheName As String) As String If FormulaCache Is Nothing Then Set FormulaCache = CreateObject("Scripting.Dictionary") If FormulaCache.Exists(cacheName) Then diff --git a/src/sh/tuk/sheet/C1.cls b/src/sh/tuk/sheet/C1.cls index 77729bc..b6a134b 100644 --- a/src/sh/tuk/sheet/C1.cls +++ b/src/sh/tuk/sheet/C1.cls @@ -141,6 +141,9 @@ Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 9 Then Dim cellI As Range For Each cellI In Target + ' Always clear address2 (content + dropdown) when address1 changes; + ' new dropdown will be rebuilt by BuildAddress2Dropdown below + Call ClearAddress2(cellI.Row) Call BuildAddress2Dropdown(cellI.Row, Trim(Me.Cells(cellI.Row, CSHAINNO_COL).Value)) Next End If @@ -663,39 +666,27 @@ End Sub ' when cshainno does not exist in o1, clear dropdownList and value ' when cshainno exist in o1, create dropdownList and value Private Sub BuildAddress1Dropdown(ByVal rowNum As Long, ByVal cshainno As String) - Dim o1Cache As Object: Set o1Cache = GetCache(CACHE_O1) - ' Build dropdown list from O1 cache: get all E values for the C - Dim dropdownList As String - If o1Cache.Exists(cshainno) Then - Dim innerDict As Object - Set innerDict = o1Cache(cshainno) - 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 address1 - 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 + ' Write address1 unique values to Caches sheet as Text, then reference that range. + ' This bypasses xlValidateList comma-string parsing that auto-coerces + ' date-like values (e.g. "2623-41") into dates. + Dim formula As String: formula = WriteCachesSheetForO1Address1(cshainno, rowNum) + If formula = "" Then Exit Sub + + With Me.Range("I" & rowNum).Validation + .Delete + .Add Type:=xlValidateList, Formula1:=formula + .IgnoreBlank = True + .InCellDropdown = True + .InputTitle = "" + .InputMessage = "" + End With End Sub Private Sub ReFillAddress1(ByVal rowNum As Long, ByVal cshainno As String) Dim o1Cache As Object: Set o1Cache = GetCache(CACHE_O1) If Not o1Cache.Exists(cshainno) Then Me.Cells(rowNum, ADDRESS1_COL).Value = "" + Call ClearAddress2(rowNum) Exit Sub End If @@ -710,54 +701,30 @@ Private Sub ReFillAddress1(ByVal rowNum As Long, ByVal cshainno As String) Dim originalValue As String: originalValue = Trim(Me.Cells(rowNum, ADDRESS1_COL).Value) If originalValue = "" Then Exit Sub - ' Clear if value not found in O1 cache keys + ' Clear if value not found in O1 cache keys (cascade clear address2 too) If Not innerDict.Exists(originalValue) Then Me.Cells(rowNum, ADDRESS1_COL).Value = "" + Call ClearAddress2(rowNum) End If End Sub ' triggered by address1 select O1 cache Private Sub BuildAddress2Dropdown(ByVal rowNum As Long, ByVal cshainno As String) - ' Clear address2 contents - ' obtain cshainno, address1, o1Cache - Dim o1Cache As Object: Set o1Cache = GetCache(CACHE_O1) Dim address1 As String: address1 = Trim(Me.Cells(rowNum, ADDRESS1_COL).Value) - If cshainno = "" OR address1 = "" Then - Exit Sub - End If - - ' Build dropdown list from O1 cache - Dim dropdownList As String - If o1Cache.Exists(cshainno) Then - Dim innerDict As Object - Set innerDict = o1Cache(cshainno) + If cshainno = "" OR address1 = "" Then Exit Sub - If innerDict.Exists(address1) Then - Dim addr2Dict As Object - Set addr2Dict = innerDict(address1) + ' Write address2 unique values to Caches sheet as Text, then reference that range. + Dim formula As String: formula = WriteCachesSheetForO1Address2(cshainno, address1, rowNum) + If formula = "" Then Exit Sub - Dim addr2Key As Variant - For Each addr2Key In addr2Dict.Keys - If dropdownList = "" Then - dropdownList = addr2Key - Else - dropdownList = dropdownList & "," & addr2Key - End If - Next addr2Key - End If - End If - - ' Create dropdown for J column - If dropdownList <> "" Then - With Me.Range("J" & rowNum).Validation - .Delete - .Add Type:=xlValidateList, Formula1:=dropdownList - .IgnoreBlank = True - .InCellDropdown = True - .InputTitle = "" - .InputMessage = "" - End With - End If + With Me.Range("J" & rowNum).Validation + .Delete + .Add Type:=xlValidateList, Formula1:=formula + .IgnoreBlank = True + .InCellDropdown = True + .InputTitle = "" + .InputMessage = "" + End With End Sub Private Sub ReFillAddress2(ByVal rowNum As Long, ByVal cshainno As String) @@ -785,8 +752,18 @@ Private Sub ReFillAddress2(ByVal rowNum As Long, ByVal cshainno As String) Me.Cells(rowNum, ADDRESS2_COL).Value = keys(0) Exit Sub End If - - Me.Cells(rowNum, ADDRESS2_COL).Value = "" + + ' Only clear if current value is not in the cache (matches ReFillAddress1 pattern) + Dim originalValue As String: originalValue = Trim(Me.Cells(rowNum, ADDRESS2_COL).Value) + If originalValue <> "" And Not addr2Dict.Exists(originalValue) Then + Me.Cells(rowNum, ADDRESS2_COL).Value = "" + End If +End Sub + +' Clear address2 cell content and validation (removes dropdown arrow too) +Private Sub ClearAddress2(ByVal rowNum As Long) + Me.Cells(rowNum, ADDRESS2_COL).ClearContents + Me.Range("J" & rowNum).Validation.Delete End Sub ' Create station from dropdown from M1_KukanD cache diff --git a/通勤手当テンプレート20260528.xlsm b/通勤手当テンプレート20260528.xlsm index 6ee3fcd..31f3d2b 100644 Binary files a/通勤手当テンプレート20260528.xlsm and b/通勤手当テンプレート20260528.xlsm differ diff --git a/通勤手当テンプレート20260604.xlsm b/通勤手当テンプレート20260604.xlsm new file mode 100644 index 0000000..9aec81f Binary files /dev/null and b/通勤手当テンプレート20260604.xlsm differ diff --git a/通勤手当テンプレート20260622.xlsm b/通勤手当テンプレート20260622.xlsm new file mode 100644 index 0000000..936c546 Binary files /dev/null and b/通勤手当テンプレート20260622.xlsm differ