UPDSV7-1081 【製造】諸手当一括取込 追加対応 通勤定期券対応

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

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

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)
+    ' Write address1 unique values to Caches sheet as Text, then reference that range.
-    ' Build dropdown list from O1 cache: get all E values for the C
+    ' This bypasses xlValidateList comma-string parsing that auto-coerces
-    Dim dropdownList As String
+    ' date-like values (e.g. "2623-41") into dates.
-    If o1Cache.Exists(cshainno) Then
+    Dim formula As String: formula = WriteCachesSheetForO1Address1(cshainno, rowNum)
-        Dim innerDict As Object
+    If formula = "" Then Exit Sub
-        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
+        .Add Type:=xlValidateList, Formula1:=formula
         .IgnoreBlank = True
         .InCellDropdown = True
         .InputTitle = ""
         .InputMessage = ""
     End With
-    End If
 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
+    If cshainno = "" OR address1 = "" Then Exit Sub
-        Exit Sub
-    End If
 
-    ' Build dropdown list from O1 cache
+    ' Write address2 unique values to Caches sheet as Text, then reference that range.
-    Dim dropdownList As String
+    Dim formula As String: formula = WriteCachesSheetForO1Address2(cshainno, address1, rowNum)
-    If o1Cache.Exists(cshainno) Then
+    If formula = "" Then Exit Sub
-        Dim innerDict As Object
-        Set innerDict = o1Cache(cshainno)
 
-        If innerDict.Exists(address1) Then
-          Dim addr2Dict As Object
-          Set addr2Dict = innerDict(address1)
-
-            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
+        .Add Type:=xlValidateList, Formula1:=formula
         .IgnoreBlank = True
         .InCellDropdown = True
         .InputTitle = ""
         .InputMessage = ""
     End With
-    End If
 End Sub
 
 Private Sub ReFillAddress2(ByVal rowNum As Long, ByVal cshainno As String)
@@ -786,7 +753,17 @@ Private Sub ReFillAddress2(ByVal rowNum As Long, ByVal cshainno As String)
         Exit Sub
     End If
 
+    ' 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