通勤認定エクセルツール対応13 M1 対応2

2026-05-28 20:57:47 +09:00
parent 50ef0c74cc
commit 29c9200132
15 changed files with 730 additions and 318 deletions
@@ -98,12 +98,9 @@ Function LoadLookup(ByVal sheetName As String, ByVal cacheName As String) As Obj
    
    ' --- obtain worksheet ---
    Dim ws As Worksheet
-    On Error Resume Next
-    Set ws = ThisWorkbook.Worksheets(sheetName)
    On Error GoTo ErrHandler
-    If ws Is Nothing Then
-        Err.Raise ERR_SHEET_MISSING, "LoadLookup", "Worksheet '" & sheetName & "' not found."
-    End If
+    Set ws = ThisWorkbook.Worksheets(sheetName)
+    ' ws exists, continue
    
    Dim sheetConf As Object: Set sheetConf = sheetConfDict(cacheName)
    Dim startRow As Long: startRow = sheetConf("StartRow")
@@ -334,39 +331,46 @@ End Function
 Public Function FormatDateInput(ByVal inputStr As String) As String
    Dim s As String: s = Trim(inputStr)
    If s = "" Then Exit Function
-    
-    ' Only process pure digit strings
-    If Not IsNumeric(s) Then
-        FormatDateInput = inputStr
+
+    ' Handle pure digit strings (YYYYMMDD / YYMMDD)
+    If IsNumeric(s) Then
+        Dim yearPart As String, monthPart As String, dayPart As String
+        Dim dateStr As String
+
+        If Len(s) = 8 Then
+            ' YYYYMMDD format
+            yearPart = Left(s, 4)
+            monthPart = Mid(s, 5, 2)
+            dayPart = Right(s, 2)
+        ElseIf Len(s) = 6 Then
+            ' YYMMDD format - add 20 prefix
+            yearPart = "20" & Left(s, 2)
+            monthPart = Mid(s, 3, 2)
+            dayPart = Right(s, 2)
+        Else
+            FormatDateInput = inputStr
+            Exit Function
+        End If
+
+        dateStr = yearPart & "-" & monthPart & "-" & dayPart
+
+        If IsDate(dateStr) Then
+            FormatDateInput = dateStr
+        Else
+            FormatDateInput = ""
+        End If
        Exit Function
    End If
-    
-    Dim yearPart As String, monthPart As String, dayPart As String
-    Dim dateStr As String
-    
-    If Len(s) = 8 Then
-        ' YYYYMMDD format
-        yearPart = Left(s, 4)
-        monthPart = Mid(s, 5, 2)
-        dayPart = Right(s, 2)
-    ElseIf Len(s) = 6 Then
-        ' YYMMDD format - add 20 prefix
-        yearPart = "20" & Left(s, 2)
-        monthPart = Mid(s, 3, 2)
-        dayPart = Right(s, 2)
-    Else
-        FormatDateInput = inputStr
+
+    ' Handle non-numeric date strings (e.g. "2026/05", "2026/5/1", "2026-5-1")
+    If IsDate(s) Then
+        Dim d As Date: d = CDate(s)
+        FormatDateInput = Year(d) & "-" & Right("0" & Month(d), 2) & "-" & Right("0" & Day(d), 2)
        Exit Function
    End If
-    
-    ' Build date string and validate
-    dateStr = yearPart & "-" & monthPart & "-" & dayPart
-    
-    If IsDate(dateStr) Then
-        FormatDateInput = dateStr
-    Else
-        FormatDateInput = inputStr
-    End If
+
+    ' Not a date - return empty string
+    FormatDateInput = ""
 End Function

 'Check header edit protection
@@ -19,7 +19,8 @@ Public Const CACHE_T3 As String = "T3"
 Public Const CACHE_O1 As String = "O1"
 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 sheetConfDict As Object
@@ -62,7 +63,7 @@ Public Sub RefreshCache(ByVal cacheName As String)
    Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
    If cacheName = "M1KukanDCache" Then
        Set loadedData = LookupM1KukanCache()
-    ElseIf cacheName = "M2" Then
+    ElseIf cacheName = CACHE_M2 Then
        Set loadedData = LookupM2Cache()
    ElseIf cacheName = CACHE_O1 Then
            Set loadedData = LookupO1Cache()
@@ -88,12 +89,9 @@ Private Function LookupM1KukanCache()
    On Error GoTo ErrHandler
    
    Dim ws As Worksheet
-    On Error Resume Next
-    Set ws = ThisWorkbook.Worksheets("M1")
-    On Error GoTo ErrHandler
-    ' ws exists, continue
+    Set ws = ThisWorkbook.Worksheets(CACHE_M1)
    
-    Dim sheetConf As Object: Set sheetConf = sheetConfDict("M1")
+    Dim sheetConf As Object: Set sheetConf = sheetConfDict(CACHE_M1)
    Dim startRow As Long: startRow = sheetConf("StartRow")
    Dim lastRow As Long: lastRow = GetLastDataRowInRange(ws)
    If lastRow < startRow Then
@@ -152,12 +150,9 @@ Private Function LookupM2Cache() As Object
    On Error GoTo ErrHandler
    
    Dim ws As Worksheet
-    On Error Resume Next
-    Set ws = ThisWorkbook.Worksheets("M2")
-    On Error GoTo ErrHandler
-    ' ws exists, continue
+    Set ws = ThisWorkbook.Worksheets(CACHE_M2)
    
-    Dim sheetConf As Object: Set sheetConf = sheetConfDict("M2")
+    Dim sheetConf As Object: Set sheetConf = sheetConfDict(CACHE_M2)
    Dim startRow As Long: startRow = sheetConf("StartRow")
    Dim lastRow As Long: lastRow = GetLastDataRowInRange(ws)
    If lastRow < startRow Then 
@@ -229,10 +224,7 @@ Private Function LookupO1Cache() As Object
    On Error GoTo ErrHandler
    
    Dim ws As Worksheet
-    On Error Resume Next
    Set ws = ThisWorkbook.Worksheets(CACHE_O1)
-    On Error GoTo ErrHandler
-    ' ws exists, continue
    
    Dim sheetConf As Object: Set sheetConf = sheetConfDict(CACHE_O1)
    Dim startRow As Long: startRow = sheetConf("StartRow")
@@ -289,7 +281,7 @@ End Function

 ' ============================================================
 ' Z4 Rosen Cache - nested dict for M1 E/F/H cascade dropdown
-' Structure: { rosen [F]: { stationFrom [D]: [stationTo E, ...] } }
+' Structure: { rosen [F]: { station [D]: True } }
 ' ============================================================
 Private Function LookupZ4RosenCache() As Object
    Dim resultCache As Object
@@ -309,31 +301,25 @@ Private Function LookupZ4RosenCache() As Object
    End If

    Dim r As Long
-    For r = startRow To lastRow
-        Dim rosen As String: rosen = Trim(ws.Cells(r, 6).Value)
-        Dim stationFrom As String: stationFrom = Trim(ws.Cells(r, 4).Value)
-        Dim stationTo As String: stationTo = Trim(ws.Cells(r, 5).Value)
+    Dim station As String
+    Dim rosen As String
+    Dim innerDict As Object

-        If rosen = "" Or stationFrom = "" Then GoTo NextRow3
+    For r = startRow To lastRow
+        rosen = Trim(ws.Cells(r, 6).Value)
+        station = Trim(ws.Cells(r, 4).Value)
+
+        If rosen = "" Or station = "" Then GoTo NextRow3

        If Not resultCache.Exists(rosen) Then
-            Dim innerDict As Object
            Set innerDict = CreateObject("Scripting.Dictionary")
            innerDict.CompareMode = vbTextCompare
            resultCache.Add rosen, innerDict
        End If

        Set innerDict = resultCache(rosen)
-        If Not innerDict.Exists(stationFrom) Then
-            Dim arr As Object
-            Set arr = CreateObject("Scripting.Dictionary")
-            arr.CompareMode = vbTextCompare
-            innerDict.Add stationFrom, arr
-        End If
-
-        Set arr = innerDict(stationFrom)
-        If stationTo <> "" And Not arr.Exists(stationTo) Then
-            arr.Add stationTo, True
+        If Not innerDict.Exists(station) Then
+            innerDict.Add station, True
        End If

 NextRow3:
@@ -387,7 +373,7 @@ Private Sub RefreshSheetDict()
    sheetConf("FilterRow") = 6
    sheetConf("KeyCol") = 3
    sheetConf("ValueCols") = Array(3, 4, 5, 6, 7, 9, 12)
-    Set sheetConfDict("M1") = sheetConf
+    Set sheetConfDict(CACHE_M1) = sheetConf
    Debug.Print "RefreshSheetDict M1 ok."

    ' M2
@@ -403,7 +389,7 @@ Private Sub RefreshSheetDict()
    sheetConf("HeaderColumns") = Array("C", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R")
    sheetConf("AlwaysQuote") = False
    sheetConf("FilterRow") = 7
-    Set sheetConfDict("M2") = sheetConf
+    Set sheetConfDict(CACHE_M2) = sheetConf
    Debug.Print "RefreshSheetDict M2 ok."

    ' Z1
@@ -479,7 +465,7 @@ Private Sub RefreshSheetDict()
    sheetConf("FilterRow") = 6
    sheetConf("KeyCol") = 3
    sheetConf("ValueCols") = Array(4)
-    Set sheetConfDict("Z4") = sheetConf
+    Set sheetConfDict(CACHE_Z4) = sheetConf
    Debug.Print "RefreshSheetDict Z4 ok."

    ' T1
@@ -517,6 +503,7 @@ Private Sub RefreshSheetDict()
        sheetConf("FilterRow") = 6
        sheetConf("KeyCol") = 3
        sheetConf("ValueCols") = Array(4, 8, 9, 10, 11, 12, 13)
+        sheetConf("ZeroFillCols") = Array("H", "I", "J", "K", "L", "M")
        Set sheetConfDict(CACHE_T2) = sheetConf
        Debug.Print "RefreshSheetDict T2 ok."

@@ -695,15 +682,15 @@ Public Sub RefreshMasterCache()
 End Sub

 Public Sub RefreshKukanCache(ByVal sheetName As String)
-    If sheetName = "M1" Then
-        Call RefreshCache("M1")
+    If sheetName = CACHE_M1 Then
+        Call RefreshCache(CACHE_M1)
        Call RefreshCache("M1KukanDCache")
        Call RefreshCache(CACHE_Z4ROSEN)
-        Call WriteCachesSheet("M1")
+        Call WriteCachesSheet(CACHE_M1)
    End If
-    If sheetName = "M2" Then
-        Call RefreshCache("M2")
-        Call WriteCachesSheet("M2")
+    If sheetName = CACHE_M2 Then
+        Call RefreshCache(CACHE_M2)
+        Call WriteCachesSheet(CACHE_M2)
    End If
 End Sub

@@ -729,7 +716,7 @@ Public Sub WriteCachesSheet(ByVal cacheName As String)
        Case CACHE_T3: colLetter = "G"
        Case CACHE_O2: colLetter = "H"
        Case CACHE_O3: colLetter = "I"
-        Case "M1": colLetter = "M"
+        Case CACHE_M1: colLetter = "M"
        Case Else: Exit Sub
    End Select
    
@@ -264,18 +264,17 @@ Public Sub BuildZ4StationToDropdown(ws As Worksheet, ByVal columnLetter As Strin
    If Not z4RosenCache.Exists(rosen) Then Exit Sub

    Dim stationFromDict As Object: Set stationFromDict = z4RosenCache(rosen)
-    If Not stationFromDict.Exists(stationFrom) Then Exit Sub
-
-    Dim stationToDict As Object: Set stationToDict = stationFromDict(stationFrom)
    Dim dropdownList As String: dropdownList = ""
-    Dim stationTo As Variant
-    For Each stationTo In stationToDict.Keys
-        If dropdownList = "" Then
-            dropdownList = stationTo
-        Else
-            dropdownList = dropdownList & "," & stationTo
+    Dim s As Variant
+    For Each s In stationFromDict.Keys
+        If s <> stationFrom Then
+            If dropdownList = "" Then
+                dropdownList = s
+            Else
+                dropdownList = dropdownList & "," & s
+            End If
        End If
-    Next stationTo
+    Next s

    If dropdownList = "" Then Exit Sub

@@ -1,7 +1,7 @@
 Attribute VB_Name = "Common_Shape"
 Option Explicit

-' ================= 通用排版引擎（仅调整位置） =================
+' ================= Common Layout Engine (position only) =================

 Public Sub AlignIconsByCenter(sheetName As String, anchorAddr As String, _
                          iconArr As Variant, gapPt As Double)
@@ -10,16 +10,14 @@ Public Sub AlignIconsByCenter(sheetName As String, anchorAddr As String, _
    Dim shp As Shape
    Dim i As Long
    Dim shapeCount As Long
-    
-    On Error Resume Next
+    On Error GoTo ErrHandler
    Set ws = ThisWorkbook.Worksheets(sheetName)
-    On Error GoTo 0
-    If ws Is Nothing Then Exit Sub
+    ' ws exists, continue
    
    Set anchor = ws.Range(anchorAddr)
    shapeCount = UBound(iconArr) - LBound(iconArr) + 1
    
-    ' 第一个图标左边对齐B3左边
+    ' First icon left-aligns to B3 left edge
    Dim curX As Double: curX = anchor.Left
    Dim prevX As Double: prevX = 0
    Dim cy As Double: cy = anchor.Top + anchor.Height / 2
@@ -39,12 +37,17 @@ Public Sub AlignIconsByCenter(sheetName As String, anchorAddr As String, _
        curX = curX + shp.Width + gapPt
    Next i
    Application.ScreenUpdating = True
+    Exit Sub
+
+ErrHandler:
+    MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "AlignIconsByCenter"
+    Application.ScreenUpdating = True
 End Sub

-' ================= 你的专属调用入口 =================
+' ================= Entry point =================
 Sub RunAlignForMySheet()
    AlignIconsByCenter _
-        sheetName:="M1", _
+        sheetName:=CACHE_M1, _
        anchorAddr:="B3", _
        iconArr:=Array("input", "check", "output", "sort", "filter", "fit", "load"), _
        gapPt:=10