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

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

Browse Source
This commit is contained in:
guanxiangwei
2026-06-22 12:40:29 +09:00
parent 688ca30ca9
commit c31130519c
6 changed files with 258 additions and 67 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/sh/tuk/init_module/ThisWorkbook.cls
+118
View File
@@ -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
+96
View File
@@ -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
+44 -67
View File
@@ -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
通勤手当テンプレート20260528.xlsm
BIN
View File
Binary file not shown.
通勤手当テンプレート20260604.xlsm
BIN
View File
Binary file not shown.
通勤手当テンプレート20260622.xlsm
BIN
View File
Binary file not shown.