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

198
src/init_module/Import_modules.bas Normal file
View File

@@ -0,0 +1,198 @@
Option Explicit
' Main entry: Validate all files and targets first. Import only if everything is OK.
Sub ImportModulesAndSheets_Safe()
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Const MODULE_PATH As String = "D:\Project\upds7\vba\src\module"
Const SHEET_PATH As String = "D:\Project\upds7\vba\src\sheet"
' --- Phase 1: Validation ---
Debug.Print "[LOG] Starting validation phase..."
Dim validationErrors As String
validationErrors = ValidateAllFilesAndTargets(MODULE_PATH, SHEET_PATH)
If validationErrors <> "" Then
MsgBox "Validation failed. Import aborted:" & vbCrLf & vbCrLf & validationErrors, vbCritical
Debug.Print "[LOG] Validation failed. Aborting import."
Exit Sub
End If
' --- Phase 2: Perform import ---
On Error GoTo ImportError
Application.ScreenUpdating = False
Debug.Print "[LOG] Validation passed. Starting import phase..."
ImportStandardModules MODULE_PATH
ImportSheetCLSFiles SHEET_PATH
Application.ScreenUpdating = True
MsgBox "All .bas and .cls files imported successfully!", vbInformation
Debug.Print "[LOG] Import completed successfully."
Exit Sub
ImportError:
Application.ScreenUpdating = True
MsgBox "Error during import: " & Err.Description, vbCritical
Debug.Print "[ERROR] Import error (" & Err.Number & "): " & Err.Description
End Sub
' Validate existence of folders, files, and target components
Private Function ValidateAllFilesAndTargets(modulePath As String, sheetPath As String) As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim msg As String
' Check module folder
Debug.Print "[LOG] Validating module folder: " & modulePath
If Not fso.FolderExists(modulePath) Then
msg = msg & "• Module folder not found: " & modulePath & vbCrLf
Debug.Print "[WARNING] Module folder not found."
Else
Dim file As Object
For Each file In fso.GetFolder(modulePath).Files
If LCase(fso.GetExtensionName(file.Name)) = "bas" Then
Dim modName As String
modName = fso.GetBaseName(file.Name)
Debug.Print "[LOG] Found .bas file: " & file.Name & " (CodeName: " & modName & ")"
If Not IsValidVBComponentName(modName) Then
msg = msg & "• Invalid module name (.bas): '" & modName & "'" & vbCrLf
Debug.Print "[WARNING] Invalid module name: " & modName
End If
End If
Next file
End If
' Check sheet folder
Debug.Print "[LOG] Validating sheet folder: " & sheetPath
If Not fso.FolderExists(sheetPath) Then
msg = msg & "• Sheet macro folder not found: " & sheetPath & vbCrLf
Debug.Print "[WARNING] Sheet folder not found."
Else
For Each file In fso.GetFolder(sheetPath).Files
If LCase(fso.GetExtensionName(file.Name)) = "cls" Then
Dim sheetCodeName As String
sheetCodeName = fso.GetBaseName(file.Name)
Debug.Print "[LOG] Found .cls file: " & file.Name & " (Target CodeName: " & sheetCodeName & ")"
Dim cmp As Object
On Error Resume Next
Set cmp = ThisWorkbook.VBProject.VBComponents(sheetCodeName)
On Error GoTo 0
If cmp Is Nothing Then
msg = msg & "• No worksheet with CodeName: '" & sheetCodeName & "'" & vbCrLf
Debug.Print "[WARNING] Worksheet with CodeName '" & sheetCodeName & "' not found."
ElseIf cmp.Type <> 100 Then ' 100 = xlWorksheet
msg = msg & "• Name exists but is not a worksheet: '" & sheetCodeName & "'" & vbCrLf
Debug.Print "[WARNING] Component '" & sheetCodeName & "' exists but is not a worksheet."
End If
End If
Next file
End If
ValidateAllFilesAndTargets = msg
End Function
' Check if name is a valid VBA component name (ASCII only, starts with letter)
Private Function IsValidVBComponentName(name As String) As Boolean
If name = "" Then Exit Function
If Not (name Like "[A-Za-z]*") Then Exit Function
Dim i As Long
For i = 1 To Len(name)
Dim c As String
c = Mid(name, i, 1)
If Not (c Like "[A-Za-z0-9_]") Then Exit Function
Next i
IsValidVBComponentName = True
End Function
' Import all .bas files as standard modules (assumes validation passed)
Private Sub ImportStandardModules(folderPath As String)
Dim fso As Object, file As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Debug.Print "[LOG] Starting import of standard modules from: " & folderPath
For Each file In fso.GetFolder(folderPath).Files
If LCase(fso.GetExtensionName(file.Name)) = "bas" Then
Dim modName As String
modName = fso.GetBaseName(file.Name)
Debug.Print "[LOG] Processing module: " & file.Path
' Remove existing module if any
On Error Resume Next
ThisWorkbook.VBProject.VBComponents.Remove ThisWorkbook.VBProject.VBComponents(modName)
On Error GoTo 0
Debug.Print "[LOG] Removed existing module (if any): " & modName
' Import new one
ThisWorkbook.VBProject.VBComponents.Import file.Path
Debug.Print "[LOG] Successfully imported: " & file.Path
End If
Next file
Debug.Print "[LOG] Finished importing standard modules."
End Sub
' Import .cls files into worksheet code modules (by CodeName)
Private Sub ImportSheetCLSFiles(folderPath As String)
Dim fso As Object, file As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Debug.Print "[LOG] Starting import of sheet code modules from: " & folderPath
For Each file In fso.GetFolder(folderPath).Files
If LCase(fso.GetExtensionName(file.Name)) = "cls" Then
Dim sheetCodeName As String
sheetCodeName = fso.GetBaseName(file.Name)
Debug.Print "[LOG] Processing sheet code: " & file.Path & " -> " & sheetCodeName
Dim cmp As Object
Set cmp = ThisWorkbook.VBProject.VBComponents(sheetCodeName) ' Safe: already validated
Dim pureCode As String
pureCode = ExtractPureCodeFromCls(file.Path)
With cmp.CodeModule
If .CountOfLines > 0 Then .DeleteLines 1, .CountOfLines
If Trim(pureCode) <> "" Then .AddFromString pureCode
End With
Debug.Print "[LOG] Successfully updated code for: " & sheetCodeName
End If
Next file
Debug.Print "[LOG] Finished importing sheet code modules."
End Sub
' Extract only the VBA source code from a .cls file (skip VERSION, BEGIN, Attribute lines)
Private Function ExtractPureCodeFromCls(filePath As String) As String
Dim fso As Object, ts As Object, line As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.OpenTextFile(filePath, 1)
Dim result As String
Dim inCodeSection As Boolean: inCodeSection = False
Do While Not ts.AtEndOfStream
line = ts.ReadLine
If inCodeSection Then
result = result & line & vbCrLf
Else
Dim tLine As String: tLine = Trim(line)
If tLine = "" Then
inCodeSection = True
ElseIf Left(tLine, 7) = "VERSION" Or _
Left(tLine, 5) = "BEGIN" Or _
Left(tLine, 3) = "END" Or _
Left(tLine, 9) = "Attribute" Then
' Skip metadata lines
Else
inCodeSection = True
result = result & line & vbCrLf
End If
End If
Loop
ts.Close
ExtractPureCodeFromCls = result
End Function

2
src/module/Test_Cache.bas → src/init_module/Test_Cache.bas
View File

@@ -1,3 +1,5 @@
Attribute VB_Name = "Test_Cache"
Option Explicit
' ============================================================
' Module Name: Test_Cache
' Module Desc: Debug module to print cache contents to Test_Cache sheet

112
src/module/Common_Button.bas Normal file
View File

@@ -0,0 +1,112 @@
Attribute VB_Name = "Common_Button"
Option Explicit
' ============================================================
' Module Name: Common_Button
' Module Desc: Common_Button
' Module Methods:
' - Import
' ============================================================
Sub CSV_Import_Button()
DO_CSV_Import ActiveSheet
End Sub
Sub Validation_Button()
Do_Validation ActiveSheet
End Sub
Sub CSV_Export_Button()
CSV_Import ActiveSheet
End Sub
Sub Do_Sort_Button()
Do_Sort ActiveSheet
End Sub
Sub Do_Filter_Button()
Do_Filter ActiveSheet
End Sub
Sub Do_Fit_Button()
Do_Fit ActiveSheet
End Sub
Private Sub DO_CSV_Import(ws As Excel.Worksheet)
Dim macroName As String
macroName = ws.CodeName & ".Import"
If Not ProcedureExists(ws.CodeName, "Import") Then
MsgBox "worksheet """ & ws.name & """ unimplement methods", vbExclamation
Exit Sub
End If
On Error GoTo ErrorHandler
Application.Run macroName, ws
Exit Sub
ErrorHandler:
MsgBox "error" & Err.Description, vbCritical
End Sub
Private Sub Do_Validation(ws As Excel.Worksheet)
If dataRangeDict Is Nothing Then Call RefreshDataRangeDict
Dim dataRange As Variant: dataRange = dataRangeDict(ws.CodeName)
' step1. confirm Validate Sub
Dim validate As String
validate = ws.CodeName & ".Validate"
If Not ProcedureExists(ws.CodeName, "Validate") Then
MsgBox "worksheet """ & ws.name & """ unimplement methods", vbExclamation
Exit Sub
End If
' step2. confirm data range
Dim lastDataRow As Long, r As Long, errorCount As Long
lastDataRow = GetLastDataRowInRange(ws)
Dim startRow As Long: startRow = dataRange(3)
Dim errorCol As Long: errorCol = ws.Range(dataRange(2) & "1").Column
If lastDataRow < startRow Then
MsgBox "No data found.", vbExclamation
Exit Sub
End If
For r = startRow To lastDataRow
On Error GoTo ErrorHandler
Application.Run validate, ws, r, lastDataRow
If Trim(ws.Cells(r, errorCol).Value) <> "" Then
errorCount = errorCount + 1
End If
Next r
' === Refresh ws cache after validation passes ===
If errorCount = 0 Then
Dim cacheMethodName As String: cacheMethodName = dataRange(5)
If
'' TODO
Call RefreshM1Cache
End If
MsgBox "Validation complete. Errors: " & errorCount, vbInformation
ErrorHandler:
MsgBox "error" & Err.Description, vbCritical
End Sub
Private Function ProcedureExists(moduleName As String, procName As String) As Boolean
Dim VBProj As Object, VBComp As Object, CodeMod As Object
Set VBProj = ThisWorkbook.VBProject
Set VBComp = VBProj.VBComponents(moduleName)
If Not VBComp Is Nothing Then
Set CodeMod = VBComp.CodeModule
ProcedureExists = (CodeMod.ProcStartLine(procName, 0) > 0)
End If
End Function

543
src/module/Read_Common.bas → src/module/Common_File_Utils.bas
View File

@@ -1,198 +1,347 @@
' ============================================================
' Module Name: Read_Common
' Module Desc: CSV read functions
' Module Methods:
' - SelectCSVFile
' - ReadCSVAs2DArrayStrict
' - ParseCSVLines
' ============================================================
Function SelectCSVFile() As String
Dim fileDialog As FileDialog
Set fileDialog = Application.FileDialog(msoFileDialogFilePicker)
With fileDialog
.Filters.Clear
.Filters.Add "CSV Files", "*.csv"
.AllowMultiSelect = False
If .Show <> -1 Then
SelectCSVFile = ""
Exit Function
End If
SelectCSVFile = .SelectedItems(1)
End With
End Function
' Read a CSV file and return its content as a strict 2D array (1-based).
' All rows must have the same number of columns as the first row.
' If the file is empty and defaultColumnCount > 0, returns an empty 2D array with zero rows and defaultColumnCount columns.
' Parameters:
' filePath: Full path to the CSV file.
' charset: Text encoding (e.g., "cp932", "utf-8").
' defaultColumnCount: Optional. Used only if CSV has no rows. Must be >= 0.
Function ReadCSVAs2DArrayStrict( _
ByVal filePath As String, _
ByVal expectedColumnCount As Long, _
Optional ByVal charset As String = "cp932", _
Optional ByVal hasHeader As Boolean = False) As Variant
' === validate expectedColumnCount ===
If expectedColumnCount <= 0 Then
Err.Raise 5001, , "expectedColumnCount must be >= 1."
End If
If Dir(filePath) = "" Then
Err.Raise 5002, , "File not found: " & filePath
End If
' === read csv file ===
Dim stream As Object
Set stream = CreateObject("ADODB.Stream")
With stream
.Type = 2 ' adTypeText
.charset = charset
.Open
.LoadFromFile filePath
Dim textContent As String
textContent = .ReadText
.Close
End With
' === standardize ===
textContent = Replace(textContent, vbCrLf, vbLf)
textContent = Replace(textContent, vbCr, vbLf)
' === transfer into collection ===
Dim lines As Collection
Set lines = ParseCSVLines(textContent)
' === validate empty ===
If lines.Count = 0 Then
Err.Raise 5003, , "CSV file is empty."
End If
If lines.Count = 1 Then
If hasHeader Then
Err.Raise 5005, , "CSV file data is empty."
End If
End If
' === loop the row, validate column count ===
Dim i As Long
For i = 1 To lines.Count
Dim rowArr As Variant
rowArr = lines(i)
Dim actualCols As Long
actualCols = UBound(rowArr) - LBound(rowArr) + 1
If actualCols <> expectedColumnCount Then
Err.Raise 5004, , "Row " & i & ": Expected " & expectedColumnCount & " columns, got " & actualCols & "."
End If
Next i
Dim result As Variant
Dim startRow As Long
If hasHeader Then
startRow = 2
Else
startRow = 1
End If
ReDim result(startRow To lines.Count, 1 To expectedColumnCount)
For i = startRow To lines.Count
rowArr = lines(i)
Dim j As Long
For j = LBound(rowArr) To UBound(rowArr)
result(i, j - LBound(rowArr) + 1) = rowArr(j)
Next j
Next i
ReadCSVAs2DArrayStrict = result
End Function
' Helper function: Parse CSV text into collection of string arrays (zero-based per row)
Private Function ParseCSVLines(ByVal csvText As String) As Collection
Set ParseCSVLines = New Collection
Dim length As Long: length = Len(csvText)
If length = 0 Then Exit Function
Dim i As Long: i = 1
Dim currentField As String
Dim currentRow As Collection: Set currentRow = New Collection
Dim inQuotes As Boolean
Dim c As String
Do While i <= length
c = Mid$(csvText, i, 1)
Select Case c
Case """"
If inQuotes Then
If i < length And Mid$(csvText, i + 1, 1) = """" Then
currentField = currentField & """"
i = i + 2
Else
inQuotes = False
i = i + 1
End If
Else
inQuotes = True
i = i + 1
End If
Case ","
If inQuotes Then
currentField = currentField & c
i = i + 1
Else
' Clean field before adding
currentField = Trim(currentField)
currentField = Replace(currentField, vbCr, "")
currentField = Replace(currentField, vbLf, "")
currentRow.Add currentField
currentField = ""
i = i + 1
End If
Case vbLf
If inQuotes Then
currentField = currentField & c
i = i + 1
Else
currentRow.Add currentField
Dim arr() As String
If currentRow.Count > 0 Then
ReDim arr(0 To currentRow.Count - 1)
Dim k As Long
For k = 1 To currentRow.Count
arr(k - 1) = currentRow(k)
Next k
End If
ParseCSVLines.Add arr
Set currentRow = New Collection
currentField = ""
inQuotes = False
i = i + 1
End If
Case Else
currentField = currentField & c
i = i + 1
End Select
Loop
' Handle last row without trailing newline
If currentField <> "" Or currentRow.Count > 0 Then
' Clean field before adding
currentField = Trim(currentField)
currentField = Replace(currentField, vbCr, "")
currentField = Replace(currentField, vbLf, "")
currentRow.Add currentField
Dim lastArr() As String
If currentRow.Count > 0 Then
ReDim lastArr(0 To currentRow.Count - 1)
Dim m As Long
For m = 1 To currentRow.Count
lastArr(m - 1) = currentRow(m)
Next m
End If
ParseCSVLines.Add lastArr
End If
Attribute VB_Name = "Common_File_Utils"
Option Explicit
' ============================================================
' Module Name: Write_Common
' Module Desc: CSV write functions
' Module Methods:
' - GetSaveCSVPath
' - WriteCSVFromArray
' ============================================================
Function GetSaveCSVPath(Optional ByVal defaultName As String = "") As String
Dim savePath As String
savePath = Application.GetSaveAsFilename( _
FileFilter:="CSV Files (*.csv), *.csv", _
Title:="Save CSV", _
InitialFileName:=defaultName)
If savePath = "False" Or savePath = "" Then
GetSaveCSVPath = ""
Exit Function
End If
If InStr(1, savePath, ".csv", vbTextCompare) = 0 Then
savePath = savePath & ".csv"
End If
GetSaveCSVPath = savePath
End Function
' Writes a 2D array to a CSV file
Sub WriteCSVFromArray( _
ByVal filePath As String, _
ByVal data As Variant, _
Optional ByVal Charset As String = "shift_jis", _
Optional ByVal alwaysQuote As Boolean = False _
)
' === Input validation ===
If Not IsArray(data) Then
Err.Raise 513, , "Input 'data' must be an array."
End If
Dim numDims As Long
On Error Resume Next
numDims = ArrayDimensions(data)
On Error GoTo 0
If numDims <> 2 Then
Err.Raise 514, , "Input array must be 2-dimensional."
End If
Dim rows As Long, cols As Long
rows = UBound(data, 1) - LBound(data, 1) + 1
cols = UBound(data, 2) - LBound(data, 2) + 1
If rows = 0 Or cols = 0 Then Exit Sub ' Empty array, exit early
' === Build CSV content ===
Dim outputLines As Collection
Set outputLines = New Collection
Dim i As Long, j As Long
Dim rowStr As String
Dim field As String
Dim needsQuote As Boolean
For i = LBound(data, 1) To UBound(data, 1)
Dim fields As Variant
ReDim fields(1 To cols)
For j = LBound(data, 2) To UBound(data, 2)
' Safely convert variant to string
field = SafeToString(data(i, j))
' Determine if the field needs quoting (per RFC 4180)
needsQuote = alwaysQuote Or (InStr(field, """") > 0) Or _
(InStr(field, ",") > 0) Or _
(InStr(field, vbLf) > 0) Or _
(InStr(field, vbCrLf) > 0) Or _
(InStr(field, vbCr) > 0) Or _
(Left(field, 1) = " " Or Right(field, 1) = " ")
If needsQuote Then
' Escape double quotes: "" represents a single "
field = """" & Replace(field, """", """""") & """"
End If
fields(j - LBound(data, 2) + 1) = field
Next j
rowStr = Join(fields, ",")
outputLines.Add rowStr
Next i
' Concatenate all lines
Dim finalContent As String
finalContent = Join(CollectionToArray(outputLines), vbCrLf)
' === Write to file ===
Dim stream As Object
Set stream = CreateObject("ADODB.Stream")
With stream
.Type = 2 ' adTypeText
.Charset = Charset
.Open
.WriteText finalContent, 0 ' adWriteChar
.SaveToFile filePath, 2 ' adSaveCreateOverWrite
.Close
End With
End Sub
' Helper function: safely convert any Variant to a string
Private Function SafeToString(ByVal v As Variant) As String
On Error Resume Next
If IsNull(v) Or IsEmpty(v) Then
SafeToString = ""
Else
SafeToString = CStr(v)
End If
On Error GoTo 0
End Function
' Helper function: get the number of dimensions of an array (1, 2, ...)
Private Function ArrayDimensions(arr As Variant) As Long
Dim dimCount As Long
On Error GoTo ExitPoint
Do
dimCount = dimCount + 1
Dim tmp As Long
tmp = UBound(arr, dimCount)
Loop
ExitPoint:
ArrayDimensions = dimCount - 1
End Function
' Helper function: convert a Collection to a 1D array (for use with Join)
Private Function CollectionToArray(col As Collection) As Variant
If col.Count = 0 Then
CollectionToArray = Array()
Exit Function
End If
Dim arr() As String
ReDim arr(1 To col.Count)
Dim i As Long
For i = 1 To col.Count
arr(i) = col(i)
Next i
CollectionToArray = arr
End Function
' ============================================================
' Module Name: Read_Common
' Module Desc: CSV read functions
' Module Methods:
' - SelectCSVFile
' - ReadCSVAs2DArrayStrict
' - ParseCSVLines
' ============================================================
Function SelectCSVFile() As String
Dim fileDialog As FileDialog
Set fileDialog = Application.FileDialog(msoFileDialogFilePicker)
With fileDialog
.Filters.Clear
.Filters.Add "CSV Files", "*.csv"
.AllowMultiSelect = False
If .Show <> -1 Then
SelectCSVFile = ""
Exit Function
End If
SelectCSVFile = .SelectedItems(1)
End With
End Function
' Read a CSV file and return its content as a strict 2D array (1-based).
' All rows must have the same number of columns as the first row.
' If the file is empty and defaultColumnCount > 0, returns an empty 2D array with zero rows and defaultColumnCount columns.
' Parameters:
' filePath: Full path to the CSV file.
' charset: Text encoding (e.g., "cp932", "utf-8").
' defaultColumnCount: Optional. Used only if CSV has no rows. Must be >= 0.
Function ReadCSVAs2DArrayStrict( _
ByVal filePath As String, _
ByVal expectedColumnCount As Long, _
Optional ByVal charset As String = "cp932", _
Optional ByVal hasHeader As Boolean = False) As Variant
' === validate expectedColumnCount ===
If expectedColumnCount <= 0 Then
Err.Raise 5001, , "expectedColumnCount must be >= 1."
End If
If Dir(filePath) = "" Then
Err.Raise 5002, , "File not found: " & filePath
End If
' === read csv file ===
Dim stream As Object
Set stream = CreateObject("ADODB.Stream")
With stream
.Type = 2 ' adTypeText
.charset = charset
.Open
.LoadFromFile filePath
Dim textContent As String
textContent = .ReadText
.Close
End With
' === standardize ===
textContent = Replace(textContent, vbCrLf, vbLf)
textContent = Replace(textContent, vbCr, vbLf)
' === transfer into collection ===
Dim lines As Collection
Set lines = ParseCSVLines(textContent)
' === validate empty ===
If lines.Count = 0 Then
Err.Raise 5003, , "CSV file is empty."
End If
If lines.Count = 1 Then
If hasHeader Then
Err.Raise 5005, , "CSV file data is empty."
End If
End If
' === loop the row, validate column count ===
Dim i As Long
For i = 1 To lines.Count
Dim rowArr As Variant
rowArr = lines(i)
Dim actualCols As Long
actualCols = UBound(rowArr) - LBound(rowArr) + 1
If actualCols <> expectedColumnCount Then
Err.Raise 5004, , "Row " & i & ": Expected " & expectedColumnCount & " columns, got " & actualCols & "."
End If
Next i
Dim result As Variant
Dim startRow As Long
If hasHeader Then
startRow = 2
Else
startRow = 1
End If
ReDim result(startRow To lines.Count, 1 To expectedColumnCount)
For i = startRow To lines.Count
rowArr = lines(i)
Dim j As Long
For j = LBound(rowArr) To UBound(rowArr)
result(i, j - LBound(rowArr) + 1) = rowArr(j)
Next j
Next i
ReadCSVAs2DArrayStrict = result
End Function
' Helper function: Parse CSV text into collection of string arrays (zero-based per row)
Private Function ParseCSVLines(ByVal csvText As String) As Collection
Set ParseCSVLines = New Collection
Dim length As Long: length = Len(csvText)
If length = 0 Then Exit Function
Dim i As Long: i = 1
Dim currentField As String
Dim currentRow As Collection: Set currentRow = New Collection
Dim inQuotes As Boolean
Dim c As String
Do While i <= length
c = Mid$(csvText, i, 1)
Select Case c
Case """"
If inQuotes Then
If i < length And Mid$(csvText, i + 1, 1) = """" Then
currentField = currentField & """"
i = i + 2
Else
inQuotes = False
i = i + 1
End If
Else
inQuotes = True
i = i + 1
End If
Case ","
If inQuotes Then
currentField = currentField & c
i = i + 1
Else
' Clean field before adding
currentField = Trim(currentField)
currentField = Replace(currentField, vbCr, "")
currentField = Replace(currentField, vbLf, "")
currentRow.Add currentField
currentField = ""
i = i + 1
End If
Case vbLf
If inQuotes Then
currentField = currentField & c
i = i + 1
Else
currentRow.Add currentField
Dim arr() As String
If currentRow.Count > 0 Then
ReDim arr(0 To currentRow.Count - 1)
Dim k As Long
For k = 1 To currentRow.Count
arr(k - 1) = currentRow(k)
Next k
End If
ParseCSVLines.Add arr
Set currentRow = New Collection
currentField = ""
inQuotes = False
i = i + 1
End If
Case Else
currentField = currentField & c
i = i + 1
End Select
Loop
' Handle last row without trailing newline
If currentField <> "" Or currentRow.Count > 0 Then
' Clean field before adding
currentField = Trim(currentField)
currentField = Replace(currentField, vbCr, "")
currentField = Replace(currentField, vbLf, "")
currentRow.Add currentField
Dim lastArr() As String
If currentRow.Count > 0 Then
ReDim lastArr(0 To currentRow.Count - 1)
Dim m As Long
For m = 1 To currentRow.Count
lastArr(m - 1) = currentRow(m)
Next m
End If
ParseCSVLines.Add lastArr
End If
End Function

557
src/module/Module_Common.bas → src/module/Common_Functions.bas
View File

@@ -1,254 +1,303 @@
' ============================================================
' Module Name: Module_Common
' Module Desc: Common utility functions for all modules
' Module Methods:
' - GetLastDataRowInRange
' - ClearDataRows
' - ClearDataRow
' - SortDataRows
' - ToggleAutoFilter
' - AutoFitColumnWidth
' - GetSaveCSVPath
' ============================================================
' Common Functions
' Get CSV header from specified row and columns
Function GetCSVHeader(ByVal ws As Worksheet, ByVal colLetters As Variant, ByVal headerRow As Long) As Variant
Dim colCount As Long: colCount = UBound(colLetters) - LBound(colLetters) + 1
Dim headerArr() As String
ReDim headerArr(1 To 1, 1 To colCount)
Dim i As Long
Dim cellValue As String
For i = 0 To colCount - 1
cellValue = Trim(ws.Cells(headerRow, Columns(colLetters(i)).Column).Value)
cellValue = Replace(cellValue, vbLf, "")
cellValue = Replace(cellValue, vbCr, "")
cellValue = Replace(cellValue, vbCrLf, "")
headerArr(1, i + 1) = cellValue
Next i
GetCSVHeader = headerArr
End Function
Function CleanCSVField(ByVal inputStr As String) As String
Dim s As String
s = Trim(inputStr)
' calcute
If Len(s) > 0 Then
Select Case Left(s, 1)
Case "=", "+", "-", "@"
CleanCSVField = "'" & s
Exit Function
End Select
End If
CleanCSVField = s
End Function
Function GetLastDataRow(ByVal ws As Worksheet, ByVal columnNum As Long) As Long
GetLastDataRow = ws.Cells(ws.Rows.Count, columnNum).End(xlUp).Row
End Function
' @return dict : key = keyCol，value = Array
' @param sheetName
' @param keyCol
' @param valueCols Array(4,5,6)
' @param startRow default is 7
Function LoadLookup( _
ByVal sheetName As String, _
ByVal keyCol As Long, _
ByVal valueCols As Variant, _
Optional ByVal startRow As Long = 7 _
) As Object
' --- validate ---
If Trim(sheetName) = "" Then Exit Function
If Not IsArray(valueCols) Then
valueCols = Array(valueCols)
End If
Dim nValCols As Long: nValCols = UBound(valueCols) - LBound(valueCols) + 1
If nValCols = 0 Then Exit Function
' --- obtain worksheet ---
On Error Resume Next
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(sheetName)
On Error GoTo 0
If ws Is Nothing Then Exit Function
' --- obtain data（based on keyCol）---
Dim lastRow As Long: lastRow = ws.Cells(ws.Rows.Count, keyCol).End(xlUp).Row
If lastRow < startRow Then Exit Function
' --- prepare col ---
Dim minCol As Long: minCol = keyCol
Dim maxCol As Long: maxCol = keyCol
Dim i As Long
For i = LBound(valueCols) To UBound(valueCols)
If Not IsNumeric(valueCols(i)) Then Exit Function
Dim colNum As Long: colNum = CLng(valueCols(i))
If colNum < 1 Then Exit Function
If colNum < minCol Then minCol = colNum
If colNum > maxCol Then maxCol = colNum
Next i
' --- read ---
Dim dataRange As Range
Set dataRange = ws.Range(ws.Cells(startRow, minCol), ws.Cells(lastRow, maxCol))
Dim data As Variant: data = dataRange.Value
' --- Ensure data is a 2D array ---
If Not IsArray(data) Then
' Single cell case
Dim temp As Variant
ReDim temp(1 To 1, 1 To (maxCol - minCol + 1))
temp(1, 1) = data
data = temp
End If
' --- build ---
Dim keyOffset As Long: keyOffset = keyCol - minCol + 1
Dim valOffsets() As Long: ReDim valOffsets(0 To nValCols - 1)
For i = 0 To nValCols - 1
valOffsets(i) = valueCols(LBound(valueCols) + i) - minCol + 1
Next i
' --- write into ---
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim r As Long
For r = 1 To UBound(data, 1)
Dim key As String: key = Trim(data(r, keyOffset))
If key <> "" Then
Dim vals() As String: ReDim vals(0 To nValCols - 1)
Dim j As Long
For j = 0 To nValCols - 1
vals(j) = Trim(data(r, valOffsets(j)))
Next j
dict(key) = vals
End If
Next r
Set LoadLookup = dict
End Function
Function GetLastDataRowInRange(ws As Worksheet, ByVal startCol As Long, ByVal endCol As Long, Optional ByVal startRow As Long = 7) As Long
' --- validate ---
If startCol < 1 Then
Err.Raise 1001, "GetLastDataRowInRange", "startCol must >= 1"
End If
If endCol < 1 Then
Err.Raise 1002, "GetLastDataRowInRange", "endCol must >= 1"
End If
If endCol < startCol Then
Err.Raise 1003, "GetLastDataRowInRange", "endCol must >= startCol"
End If
If startRow < 1 Then
Err.Raise 1004, "GetLastDataRowInRange", "startRow must >= 1"
End If
' --- query max row ---
Dim colIndex As Long, lastRow As Long, maxRow As Long
maxRow = startRow - 1
For colIndex = startCol To endCol
lastRow = ws.Cells(ws.Rows.Count, colIndex).End(xlUp).Row
If lastRow > maxRow Then maxRow = lastRow
Next colIndex
GetLastDataRowInRange = maxRow
End Function
Function ClearDataRow(ByVal ws As Worksheet, ByVal startCol As Long, ByVal endCol As Long, ByVal rowRow As Long, Optional ByVal errorCol As Long = 2)
If rowRow >= 7 Then
Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowRow, startCol), ws.Cells(rowRow, endCol))
clearRange.ClearContents
clearRange.Interior.Color = vbWhite
ws.Range(ws.Cells(rowRow, errorCol), ws.Cells(rowRow, errorCol)).ClearContents
End If
End Function
Function ClearDataRows(ByVal ws As Worksheet, ByVal startCol As Long, ByVal endCol As Long, Optional ByVal startRow As Long = 7)
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws, startCol, endCol, startRow)
If lastDataRow >= startRow Then
Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(startRow, startCol), ws.Cells(lastDataRow, endCol))
clearRange.ClearContents
clearRange.Interior.Color = vbWhite
End If
End Function
Sub SortDataRows(Optional ByVal sortColumn As Long = 3)
Dim ws As Worksheet
Dim lastRow As Long
Dim startRow As Long
Dim sortOrder As Long
Set ws = ActiveSheet
startRow = 7
lastRow = GetLastDataRow(ws, sortColumn)
If lastRow < startRow Then
MsgBox "No data to sort.", vbExclamation
Exit Sub
End If
' Determine sort order based on first row's current state
Dim currentFirst As String
Dim nextFirst As String
currentFirst = Trim(ws.Cells(startRow, sortColumn).Value)
nextFirst = Trim(ws.Cells(startRow + 1, sortColumn).Value)
If currentFirst <> "" And nextFirst <> "" Then
If currentFirst > nextFirst Then
sortOrder = xlAscending
Else
sortOrder = xlDescending
End If
Else
sortOrder = xlAscending
End If
ws.Range(ws.Cells(startRow, 1), ws.Cells(lastRow, 20)).Sort _
Key1:=ws.Cells(startRow, sortColumn), _
Order1:=sortOrder, _
Header:=xlNo
End Sub
Sub ToggleAutoFilter(ByVal startColumn As Long, ByVal endColumn As Long, Optional ByVal filterRow As Long = 6)
Dim ws As Worksheet: Set ws = ActiveSheet
' Check if auto filter is already on
If ws.AutoFilterMode Then
ws.AutoFilterMode = False
Exit Sub
End If
If startColumn < 1 Or endColumn < startColumn Then Exit Sub
Dim filterRange As Range: Set filterRange = ws.Range(ws.Cells(filterRow, startColumn), ws.Cells(filterRow, endColumn))
filterRange.AutoFilter
End Sub
Sub AutoFitColumnWidth(ByVal fitColumnStart As Long, ByVal fitColumnEnd As Long)
Dim ws As Worksheet: Set ws = ActiveSheet
If fitColumnStart <= fitColumnEnd Then
ws.Range(ws.Columns(fitColumnStart), ws.Columns(fitColumnEnd)).AutoFit
End If
End Sub
' Format: code:value (no space around colon)
Function MakeSelect(ByVal code As String, ByVal value As String) As String
MakeSelect = Trim(code) & ":" & Trim(value)
End Function
' Get left part of MakeSelect format (e.g., "1:JR" -> "1")
Function GetCode(ByVal text As String) As String
Dim pos As Long: pos = InStr(text, ":")
If pos > 0 Then
GetCode = Left(text, pos - 1)
Else
GetCode = text
End If
End Function
Attribute VB_Name = "Common_Functions"
Option Explicit
' ============================================================
' Module Name: Module_Common
' Module Desc: Common utility functions for all modules
' Module Methods:
' - GetLastDataRowInRange
' - ClearDataRows
' - ClearDataRow
' - SortDataRows
' - ToggleAutoFilter
' - AutoFitColumnWidth
' ============================================================
' Common Functions
' Get CSV header from specified row and columns
Function GetCSVHeader(ByVal ws As Worksheet, ByVal colLetters As Variant, ByVal headerRow As Long) As Variant
Dim colCount As Long: colCount = UBound(colLetters) - LBound(colLetters) + 1
Dim headerArr() As String
ReDim headerArr(1 To 1, 1 To colCount)
Dim i As Long
Dim cellValue As String
For i = 0 To colCount - 1
cellValue = Trim(ws.Cells(headerRow, Columns(colLetters(i)).Column).Value)
cellValue = Replace(cellValue, vbLf, "")
cellValue = Replace(cellValue, vbCr, "")
cellValue = Replace(cellValue, vbCrLf, "")
headerArr(1, i + 1) = cellValue
Next i
GetCSVHeader = headerArr
End Function
Function CleanCSVField(ByVal inputStr As String) As String
Dim s As String
s = Trim(inputStr)
' calcute
If Len(s) > 0 Then
Select Case Left(s, 1)
Case "=", "+", "-", "@"
CleanCSVField = "'" & s
Exit Function
End Select
End If
CleanCSVField = s
End Function
Function GetLastDataRow(ByVal ws As Worksheet, ByVal columnNum As Long) As Long
GetLastDataRow = ws.Cells(ws.Rows.Count, columnNum).End(xlUp).Row
End Function
' @return dict : key = keyCol，value = Array
' @param sheetName
' @param keyCol
' @param valueCols Array(4,5,6)
' @param startRow default is 7
Function LoadLookup( _
ByVal sheetName As String, _
ByVal keyCol As Long, _
ByVal valueCols As Variant, _
Optional ByVal startRow As Long = 7 _
) As Object
' --- validate ---
If Trim(sheetName) = "" Then Exit Function
If Not IsArray(valueCols) Then
valueCols = Array(valueCols)
End If
Dim nValCols As Long: nValCols = UBound(valueCols) - LBound(valueCols) + 1
If nValCols = 0 Then Exit Function
' --- obtain worksheet ---
On Error Resume Next
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(sheetName)
On Error GoTo 0
If ws Is Nothing Then Exit Function
' --- obtain data（based on keyCol）---
Dim lastRow As Long: lastRow = ws.Cells(ws.Rows.Count, keyCol).End(xlUp).Row
If lastRow < startRow Then Exit Function
' --- prepare col ---
Dim minCol As Long: minCol = keyCol
Dim maxCol As Long: maxCol = keyCol
Dim i As Long
For i = LBound(valueCols) To UBound(valueCols)
If Not IsNumeric(valueCols(i)) Then Exit Function
Dim colNum As Long: colNum = CLng(valueCols(i))
If colNum < 1 Then Exit Function
If colNum < minCol Then minCol = colNum
If colNum > maxCol Then maxCol = colNum
Next i
' --- read ---
Dim dataRange As Range
Set dataRange = ws.Range(ws.Cells(startRow, minCol), ws.Cells(lastRow, maxCol))
Dim data As Variant: data = dataRange.Value
' --- Ensure data is a 2D array ---
If Not IsArray(data) Then
' Single cell case
Dim temp As Variant
ReDim temp(1 To 1, 1 To (maxCol - minCol + 1))
temp(1, 1) = data
data = temp
End If
' --- build ---
Dim keyOffset As Long: keyOffset = keyCol - minCol + 1
Dim valOffsets() As Long: ReDim valOffsets(0 To nValCols - 1)
For i = 0 To nValCols - 1
valOffsets(i) = valueCols(LBound(valueCols) + i) - minCol + 1
Next i
' --- write into ---
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim r As Long
For r = 1 To UBound(data, 1)
Dim key As String: key = Trim(data(r, keyOffset))
If key <> "" Then
Dim vals() As String: ReDim vals(0 To nValCols - 1)
Dim j As Long
For j = 0 To nValCols - 1
vals(j) = Trim(data(r, valOffsets(j)))
Next j
dict(key) = vals
End If
Next r
Set LoadLookup = dict
End Function
' obtain
Function GetLastDataRowInRange(ws As Worksheet) As Long
If dataRangeDict Is Nothing Then Call RefreshDataRangeDict
If dataRangeDict.Exists(ws.CodeName) Then
Dim dataRange As Variant: dataRange = dataRangeDict(ws.CodeName)
Dim startCol As Long, endCol As Long, startRow As Long
On Error GoTo InvalidColumn
startCol = ws.Range(dataRange(0) & "1").Column
endCol = ws.Range(dataRange(1) & "1").Column
startRow = dataRange(3)
On Error GoTo 0
' --- query max row ---
Dim colIndex As Long, lastRow As Long, maxRow As Long
maxRow = startRow - 1
For colIndex = startCol To endCol
lastRow = ws.Cells(ws.Rows.Count, colIndex).End(xlUp).Row
If lastRow > maxRow Then maxRow = lastRow
Next colIndex
GetLastDataRowInRange = maxRow
Else
Err.Raise 1004, "GetLastDataRowInRange", "Sheet not configured: " & ws.CodeName
End If
Exit Function
InvalidColumn:
Err.Raise 1005, "GetLastDataRowInRange", "Invalid column letter for sheet: " & ws.CodeName
End Function
Function ClearDataRow(ByVal ws As Worksheet, ByVal startCol As Long, ByVal endCol As Long, ByVal rowRow As Long, Optional ByVal errorCol As Long = 2)
If rowRow >= 7 Then
Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowRow, startCol), ws.Cells(rowRow, endCol))
clearRange.ClearContents
clearRange.Interior.Color = vbWhite
ws.Range(ws.Cells(rowRow, errorCol), ws.Cells(rowRow, errorCol)).ClearContents
End If
End Function
Function ClearDataRows(ByVal ws As Worksheet, ByVal startCol As Long, ByVal endCol As Long, Optional ByVal startRow As Long = 7)
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws, startCol, endCol, startRow)
If lastDataRow >= startRow Then
Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(startRow, startCol), ws.Cells(lastDataRow, endCol))
clearRange.ClearContents
clearRange.Interior.Color = vbWhite
End If
End Function
Sub SortDataRows(Optional ByVal sortColumn As Long = 3)
Dim ws As Worksheet
Dim lastRow As Long
Dim startRow As Long
Dim sortOrder As Long
Set ws = ActiveSheet
startRow = 7
lastRow = GetLastDataRow(ws, sortColumn)
If lastRow < startRow Then
MsgBox "No data to sort.", vbExclamation
Exit Sub
End If
' Determine sort order based on first row's current state
Dim currentFirst As String
Dim nextFirst As String
currentFirst = Trim(ws.Cells(startRow, sortColumn).Value)
nextFirst = Trim(ws.Cells(startRow + 1, sortColumn).Value)
If currentFirst <> "" And nextFirst <> "" Then
If currentFirst > nextFirst Then
sortOrder = xlAscending
Else
sortOrder = xlDescending
End If
Else
sortOrder = xlAscending
End If
ws.Range(ws.Cells(startRow, 1), ws.Cells(lastRow, 20)).Sort _
Key1:=ws.Cells(startRow, sortColumn), _
Order1:=sortOrder, _
Header:=xlNo
End Sub
Sub ToggleAutoFilter(ByVal startColumn As Long, ByVal endColumn As Long, Optional ByVal filterRow As Long = 6)
Dim ws As Worksheet: Set ws = ActiveSheet
' Check if auto filter is already on
If ws.AutoFilterMode Then
ws.AutoFilterMode = False
Exit Sub
End If
If startColumn < 1 Or endColumn < startColumn Then Exit Sub
Dim filterRange As Range: Set filterRange = ws.Range(ws.Cells(filterRow, startColumn), ws.Cells(filterRow, endColumn))
filterRange.AutoFilter
End Sub
Sub AutoFitColumnWidth(ByVal fitColumnStart As Long, ByVal fitColumnEnd As Long)
Dim ws As Worksheet: Set ws = ActiveSheet
If fitColumnStart <= fitColumnEnd Then
ws.Range(ws.Columns(fitColumnStart), ws.Columns(fitColumnEnd)).AutoFit
End If
End Sub
' Format: code:value (no space around colon)
Function MakeSelect(ByVal code As String, ByVal value As String) As String
MakeSelect = Trim(code) & ":" & Trim(value)
End Function
' Get left part of MakeSelect format (e.g., "1:JR" -> "1")
Function GetCode(ByVal text As String) As String
Dim pos As Long: pos = InStr(text, ":")
If pos > 0 Then
GetCode = Left(text, pos - 1)
Else
GetCode = text
End If
End Function
' ============================================================
' Format date input: YYYYMMDD or YYMMDD -> YYYY-MM-DD
' ============================================================
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
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
Exit Function
End If
' Build date string and validate
dateStr = yearPart & "-" & monthPart & "-" & dayPart
If IsDate(dateStr) Then
FormatDateInput = dateStr
Else
FormatDateInput = inputStr
End If
End Function

2
src/module/Generic_Master_Common.bas → src/module/Common_Generic_Master.bas
View File

@@ -1,3 +1,5 @@
Attribute VB_Name = "Common_Generic_Master"
Option Explicit
' ============================================================
' Module Name: Generic_Master_Common
' Module Desc: Generic Master Import/Export functions

74
src/module/Global_Cache.bas → src/module/Common_Global_Cache.bas
View File

@@ -1,15 +1,17 @@
Attribute VB_Name = "Common_Global_Cache"
Option Explicit
' ============================================================
' Module Name: Global_Cache
' Module Desc: Global Cache Module, Shared caches across all worksheets
' Module Methods:
' - RefreshM1Cache / ClearM1Cache
' - RefreshM1KukanDCache / ClearM1KukanDCache
' - RefreshM2Cache / ClearM2Cache
' - RefreshZ1Cache / ClearZ1Cache
' - RefreshZ2Cache / ClearZ2Cache
' - RefreshZ3Cache / ClearZ3Cache
' - RefreshO1Cache / ClearO1Cache
' - RefreshO2Cache / ClearO2Cache
' - RefreshM1Cache
' - RefreshM1KukanDCache
' - RefreshM2Cache
' - RefreshZ1Cache
' - RefreshZ2Cache
' - RefreshZ3Cache
' - RefreshO1Cache
' - RefreshO2Cache
' ============================================================
' Cache Variables
@@ -27,6 +29,8 @@ Public oufukuList As Object
Public koutaiList As Object
Public higaitouList As Object
Public dataRangeDict As Object
' m1Cache - used by M2_Kukan_detail, Tukin_C1
' m1KukanDCache - nested dict {D: {F: [G]}}
' z1Cache - used by M1_Kukan, Tukin_C1
@@ -56,10 +60,6 @@ RefreshError:
Err.Raise 1002, "RefreshM1Cache", "Failed to load M1 lookup cache: " & Err.Description
End Sub
Public Sub ClearM1Cache()
Set m1Cache = Nothing
End Sub
' Refresh M1_KukanD cache - nested dict {D: {F: [G]}}
' Structure: { 交通機関区分[D]: { 利用区間発名[F]: [利用区間着名G] } }
Public Sub RefreshM1KukanDCache()
@@ -105,10 +105,6 @@ NextRow2:
Next r
End Sub
Public Sub ClearM1KukanDCache()
Set m1KukanDCache = Nothing
End Sub
' ============================================================
' M2 Cache - Nested Dictionary
' Structure: { 区間コード[C]: { 券種[I]: { コード[J]: K } } }
@@ -158,10 +154,6 @@ NextRow:
Next r
End Sub
Public Sub ClearM2Cache()
Set m2Cache = Nothing
End Sub
' ============================================================
' Z1 Cache
' ============================================================
@@ -182,10 +174,6 @@ RefreshError:
Err.Raise 1002, "RefreshZ1Cache", "Failed to load Z1 lookup cache: " & Err.Description
End Sub
Public Sub ClearZ1Cache()
Set z1Cache = Nothing
End Sub
' ============================================================
' Z2 Cache
' ============================================================
@@ -206,10 +194,6 @@ RefreshError:
Err.Raise 1002, "RefreshZ2Cache", "Failed to load Z2 lookup cache: " & Err.Description
End Sub
Public Sub ClearZ2Cache()
Set z2Cache = Nothing
End Sub
' ============================================================
' Z3 Cache
' ============================================================
@@ -230,10 +214,6 @@ RefreshError:
Err.Raise 1002, "RefreshZ3Cache", "Failed to load Z3 lookup cache: " & Err.Description
End Sub
Public Sub ClearZ3Cache()
Set z3Cache = Nothing
End Sub
' ============================================================
' z4Cache
' ============================================================
@@ -252,10 +232,6 @@ RefreshError:
Err.Raise 1001, "RefreshZ4Cache", "Failed to load Enum lookup cache: " & Err.Description
End Sub
Public Sub ClearZ4Cache()
Set z4Cache = Nothing
End Sub
' ============================================================
' O1 Cache
' ============================================================
@@ -308,10 +284,6 @@ NextO1:
Next r
End Sub
Public Sub ClearO1Cache()
Set o1Cache = Nothing
End Sub
' ============================================================
' O2 Cache
' ============================================================
@@ -332,10 +304,6 @@ RefreshError:
Err.Raise 1002, "RefreshO2Cache", "Failed to load O2 lookup cache: " & Err.Description
End Sub
Public Sub ClearO2Cache()
Set o2Cache = Nothing
End Sub
' ============================================================
' tokubetuList
' ============================================================
@@ -354,10 +322,6 @@ RefreshError:
Err.Raise 1001, "GetTokubetu", "Failed to load Enum lookup cache: " & Err.Description
End Sub
Public Sub ClearTokubetu()
Set tokubetuList = Nothing
End Sub
' ============================================================
' oufukuList
' ============================================================
@@ -376,10 +340,6 @@ RefreshError:
Err.Raise 1001, "GetOufukuList", "Failed to load Enum lookup cache: " & Err.Description
End Sub
Public Sub ClearOufukuList()
Set oufukuList = Nothing
End Sub
' ============================================================
' koutaiList
' ============================================================
@@ -398,10 +358,6 @@ RefreshError:
Err.Raise 1001, "GetKoutaiList", "Failed to load Enum lookup cache: " & Err.Description
End Sub
Public Sub ClearKoutaiList()
Set koutaiList = Nothing
End Sub
' ============================================================
' higaitouList
' ============================================================
@@ -420,6 +376,8 @@ RefreshError:
Err.Raise 1001, "GetHigaitouList", "Failed to load Enum lookup cache: " & Err.Description
End Sub
Public Sub ClearHigaitouList()
Set higaitouList = Nothing
' sheetName : [START_COL, END_COL, ERROR_COL, START_ROW, HEADER_ROW, RefaushCacheName]
Public Sub RefreshDataRangeDict()
Set dataRangeDict = CreateObject("Scripting.Dictionary")
dataRangeDict("M1") = Array("C", "N", "O", 7, 5, "RefreshM1Cache")
End Sub

2
src/module/Build_Select.bas → src/module/Common_Selector.bas
View File

@@ -1,3 +1,5 @@
Attribute VB_Name = "Common_Selector"
Option Explicit
' ============================================================
' Module Name: Build_Select
' Module Desc: Commuter allowance editing sheet (no CSV import)

10
src/module/Validate_Common.bas
View File

@@ -1,10 +0,0 @@
'=============================================================================
'=============================================================================
Option Explicit
'-----------------------------------------------------------------------------
'-----------------------------------------------------------------------------
Public Function IsDateString(ByVal inputStr As String) As Boolean
End Function

146
src/module/Write_Common.bas
View File

@@ -1,146 +0,0 @@
' ============================================================
' Module Name: Write_Common
' Module Desc: CSV write functions
' Module Methods:
' - GetSaveCSVPath
' - WriteCSVFromArray
' ============================================================
Function GetSaveCSVPath(Optional ByVal defaultName As String = "") As String
Dim savePath As String
savePath = Application.GetSaveAsFilename( _
FileFilter:="CSV Files (*.csv), *.csv", _
Title:="Save CSV", _
InitialFileName:=defaultName)
If savePath = "False" Or savePath = "" Then
GetSaveCSVPath = ""
Exit Function
End If
If InStr(1, savePath, ".csv", vbTextCompare) = 0 Then
savePath = savePath & ".csv"
End If
GetSaveCSVPath = savePath
End Function
' Writes a 2D array to a CSV file
Sub WriteCSVFromArray( _
ByVal filePath As String, _
ByVal data As Variant, _
Optional ByVal Charset As String = "shift_jis", _
Optional ByVal alwaysQuote As Boolean = False _
)
' === Input validation ===
If Not IsArray(data) Then
Err.Raise 513, , "Input 'data' must be an array."
End If
Dim numDims As Long
On Error Resume Next
numDims = ArrayDimensions(data)
On Error GoTo 0
If numDims <> 2 Then
Err.Raise 514, , "Input array must be 2-dimensional."
End If
Dim rows As Long, cols As Long
rows = UBound(data, 1) - LBound(data, 1) + 1
cols = UBound(data, 2) - LBound(data, 2) + 1
If rows = 0 Or cols = 0 Then Exit Sub ' Empty array, exit early
' === Build CSV content ===
Dim outputLines As Collection
Set outputLines = New Collection
Dim i As Long, j As Long
Dim rowStr As String
Dim field As String
Dim needsQuote As Boolean
For i = LBound(data, 1) To UBound(data, 1)
Dim fields As Variant
ReDim fields(1 To cols)
For j = LBound(data, 2) To UBound(data, 2)
' Safely convert variant to string
field = SafeToString(data(i, j))
' Determine if the field needs quoting (per RFC 4180)
needsQuote = alwaysQuote Or (InStr(field, """") > 0) Or _
(InStr(field, ",") > 0) Or _
(InStr(field, vbLf) > 0) Or _
(InStr(field, vbCrLf) > 0) Or _
(InStr(field, vbCr) > 0) Or _
(Left(field, 1) = " " Or Right(field, 1) = " ")
If needsQuote Then
' Escape double quotes: "" represents a single "
field = """" & Replace(field, """", """""") & """"
End If
fields(j - LBound(data, 2) + 1) = field
Next j
rowStr = Join(fields, ",")
outputLines.Add rowStr
Next i
' Concatenate all lines
Dim finalContent As String
finalContent = Join(CollectionToArray(outputLines), vbCrLf)
' === Write to file ===
Dim stream As Object
Set stream = CreateObject("ADODB.Stream")
With stream
.Type = 2 ' adTypeText
.Charset = Charset
.Open
.WriteText finalContent, 0 ' adWriteChar
.SaveToFile filePath, 2 ' adSaveCreateOverWrite
.Close
End With
End Sub
' Helper function: safely convert any Variant to a string
Private Function SafeToString(ByVal v As Variant) As String
On Error Resume Next
If IsNull(v) Or IsEmpty(v) Then
SafeToString = ""
Else
SafeToString = CStr(v)
End If
On Error GoTo 0
End Function
' Helper function: get the number of dimensions of an array (1, 2, ...)
Private Function ArrayDimensions(arr As Variant) As Long
Dim dimCount As Long
On Error GoTo ExitPoint
Do
dimCount = dimCount + 1
Dim tmp As Long
tmp = UBound(arr, dimCount)
Loop
ExitPoint:
ArrayDimensions = dimCount - 1
End Function
' Helper function: convert a Collection to a 1D array (for use with Join)
Private Function CollectionToArray(col As Collection) As Variant
If col.Count = 0 Then
CollectionToArray = Array()
Exit Function
End If
Dim arr() As String
ReDim arr(1 To col.Count)
Dim i As Long
For i = 1 To col.Count
arr(i) = col(i)
Next i
CollectionToArray = arr
End Function

30
src/thisWorkbook/Tukin_C1.bas → src/sheet/C1.cls
View File

@@ -66,6 +66,10 @@ 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
' ============================================================
@@ -88,13 +92,16 @@ Private Sub Worksheet_Change(ByVal Target 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("AN:AR"), _
.Columns("BB") _
)
End With
Dim intersectRng As Range: Set intersectRng = Application.Intersect(Target, watchArea)
@@ -120,6 +127,17 @@ Private Sub Worksheet_Change(ByVal Target As Range)
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)
@@ -448,7 +466,7 @@ Private Sub ClearRowData(ByVal rowNum As Long)
End Sub
' ====== Button Macros ======
Sub C1_validateButton()
Private Sub validateButton()
Dim lastRow As Long, r As Long, errorCount As Long
lastRow = GetLastDataRowInRange(Me, START_COL, END_COL)
@@ -469,7 +487,7 @@ Sub C1_validateButton()
End Sub
' Validation logic
Private Sub Validate(ByVal rowNum As Long)
Private Private Sub validate(ByVal rowNum As Long)
Set ws = Me
' Clear background color
@@ -490,14 +508,14 @@ Private Sub Validate(ByVal rowNum As Long)
Me.Cells(rowNum, ERROR_COL).ClearContents
End Sub
Sub C1_SortDataRowsByC()
Private Sub Do_Sort()
Call SortDataRows(3)
End Sub
Sub C1_ToggleAutoFilter()
Private Sub Do_Filter()
Call ToggleAutoFilter(START_COL, END_COL)
End Sub
Sub C1_AutoFitColumnWidth()
Private Sub Do_Fit()
Call AutoFitColumnWidth(START_COL, END_COL)
End Sub

44
src/thisWorkbook/Master_M1_Kukan.bas → src/sheet/M1.cls
View File

@@ -1,22 +1,22 @@
' ============================================================
' Module Name: Master_M1_Kukan
' Module Name: Master_Kukan
' Module Desc: M1 Kukan master data management (import/export/validate)
' Module Methods:
' - M1_Import
' - M1_Export
' - M1_validateButton_Click
' - M1_SortDataRowsByC
' - M1_ToggleAutoFilter
' - M1_Worksheet_Change
' - M1_ValidateRow
' - M1_FillValidationDropdown
' - M1_ValidateAllRows
' - Import
' - Export
' - validateButton_Click
' - SortData
' - ToggleAutoFilter
' - Worksheet_Change
' - ValidateRow
' - FillValidationDropdown
' - ValidateAllRows
' ============================================================
' ====== Constants ======
Const START_COL As Long = 3 ' C column
Const END_COL As Long = 14 ' N column
Const ERROR_COL As Long = 15 ' O column
Const M1_HEADER_ROW As Long = 5
Const HEADER_ROW As Long = 5
Function HEADERS() As Variant
HEADERS = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N")
@@ -85,7 +85,7 @@ Private Sub Worksheet_Change(ByVal Target As Range)
End If
End Sub
Sub M1_Import()
Sub Import(wsTarget As Worksheet)
' === Step 1: Select CSV file ===
Dim filePath As String: filePath = SelectCSVFile()
If filePath = "" Then Exit Sub
@@ -102,7 +102,6 @@ Sub M1_Import()
' === Step 3:Clear all data rows before import ===
Application.EnableEvents = False
Dim wsTarget As Worksheet: Set wsTarget = Me
Call ClearDataRows(wsTarget, START_COL, END_COL, 7)
Application.EnableEvents = True
@@ -126,8 +125,7 @@ ImportError:
MsgBox "CSV import failed: " & Err.Description, vbExclamation
End Sub
Sub validate(ByVal rowNum As Long, ByVal lastDataRow As Long)
Set ws = Me
Private Sub validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
Dim clearRange As Range
Set clearRange = ws.Range(ws.Cells(rowNum, START_COL), ws.Cells(rowNum, END_COL))
@@ -207,9 +205,9 @@ Sub validate(ByVal rowNum As Long, ByVal lastDataRow As Long)
End Sub
' Validate button
Sub M1_validateButton()
Sub validateAll(ws As Worksheet)
Dim lastDataRow As Long, r As Long, errorCount As Long
lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
lastDataRow = GetLastDataRowInRange(ws, START_COL, END_COL)
If lastDataRow < 7 Then
MsgBox "No data found.", vbExclamation
@@ -218,7 +216,7 @@ Sub M1_validateButton()
For r = 7 To lastDataRow
Validate r, lastDataRow
If Trim(Cells(r, ERROR_COL).Value) <> "" Then
If Trim(ws.Cells(r, ERROR_COL).Value) <> "" Then
errorCount = errorCount + 1
End If
Next r
@@ -231,7 +229,7 @@ Sub M1_validateButton()
MsgBox "Validation complete. Errors: " & errorCount, vbInformation
End Sub
Sub M1_Export()
Private Sub Export()
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
If lastDataRow < 7 Then
MsgBox "No data rows to output.", vbExclamation
@@ -263,7 +261,7 @@ Sub M1_Export()
' === Step 4: Build array with header and data ===
Dim headerArr As Variant
Dim colLetters As Variant: colLetters = HEADERS()
headerArr = GetCSVHeader(ws, colLetters, M1_HEADER_ROW)
headerArr = GetCSVHeader(ws, colLetters, HEADER_ROW)
Dim outputArr As Variant
ReDim outputArr(1 To rowCount + 1, 1 To 12)
@@ -294,14 +292,14 @@ ExportError:
MsgBox "CSV export failed: " & Err.Description, vbExclamation
End Sub
Sub M1_SortDataRowsByC()
Private Sub Do_Sort()
Call SortDataRows(3)
End Sub
Sub M1_ToggleAutoFilter()
Private Sub Do_Filter()
Call ToggleAutoFilter(START_COL, END_COL)
End Sub
Sub M1_AutoFitColumnWidth()
Private Sub Do_Fit()
Call AutoFitColumnWidth(START_COL, END_COL)
End Sub

38
src/thisWorkbook/Master_M2_Kukan_detail.bas → src/sheet/M2.cls
View File

@@ -1,22 +1,22 @@
' ============================================================
' Module Name: Master_M2_Kukan_detail
' Module Name: Master_Kukan_detail
' Module Desc: M2 Kukan detail master data management
' Module Methods:
' - M2_Import
' - M2_Export
' - M2_validateButton_Click
' - M2_SortDataRowsByC
' - M2_ToggleAutoFilter
' - M2_Worksheet_Change
' - M2_ValidateRow
' - M2_FillValidationDropdown
' - M2_ValidateAllRows
' - Import
' - Export
' - validateButton_Click
' - SortData
' - ToggleAutoFilter
' - Worksheet_Change
' - ValidateRow
' - FillValidationDropdown
' - ValidateAllRows
' ============================================================
' ====== Constants ======
Const START_COL As Long = 3 ' C column
Const END_COL As Long = 18 ' R column
Const ERROR_COL As Long = 19 ' S column
Const M2_HEADER_ROW As Long = 6
Const HEADER_ROW As Long = 6
Function HEADERS() As Variant
HEADERS = Array("C", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R")
@@ -79,7 +79,7 @@ Sub ClearRowData(ByVal ws As Worksheet, ByVal rowNum As Long)
ws.Cells(rowNum, 19).ClearContents ' Q column error info
End Sub
Sub M2_Import()
Private Sub Import()
' === Step 1: Select CSV file ===
Dim filePath As String: filePath = SelectCSVFile()
If filePath = "" Then Exit Sub
@@ -120,7 +120,7 @@ ImportError:
MsgBox "CSV import failed: " & Err.Description, vbExclamation
End Sub
Sub validate(ByVal rowNum As Long, ByVal lastDataRow As Long)
Private Sub validate(ByVal rowNum As Long, ByVal lastDataRow As Long)
Set ws = Me
Dim clearRange As Range
@@ -171,7 +171,7 @@ Sub validate(ByVal rowNum As Long, ByVal lastDataRow As Long)
End Sub
' Button macro (Validate selected row)
Sub M2_validateButton()
Private Sub validateButton()
Dim lastDataRow As Long, r As Long, errorCount As Long
lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
@@ -190,7 +190,7 @@ Sub M2_validateButton()
MsgBox "Validation complete. Errors: " & errorCount, vbInformation
End Sub
Sub M2_Export()
Private Sub Export()
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
If lastDataRow < 7 Then
MsgBox "No data rows to output.", vbExclamation
@@ -222,7 +222,7 @@ Sub M2_Export()
' === Step 4: Build array with header and data ===
Dim headerArr As Variant
Dim colLetters As Variant: colLetters = HEADERS()
headerArr = GetCSVHeader(ws, colLetters, M2_HEADER_ROW)
headerArr = GetCSVHeader(ws, colLetters, HEADER_ROW)
Dim outputArr As Variant
ReDim outputArr(1 To rowCount + 1, 1 To 11)
@@ -254,14 +254,14 @@ ExportError:
End Sub
Sub M2_SortDataRowsByC()
Private Sub Do_Sort()
Call SortDataRows(3)
End Sub
Sub M2_ToggleAutoFilter()
Private Sub Do_Filter()
Call ToggleAutoFilter(START_COL, END_COL)
End Sub
Sub M2_AutoFitColumnWidth()
Private Sub Do_Fit()
Call AutoFitColumnWidth(START_COL, END_COL)
End Sub

18
src/thisWorkbook/Master_O1_address.bas → src/sheet/O1.cls
View File

@@ -1,13 +1,13 @@
' ============================================================
' Module Name: Master_O1_address
' Module Name: Master_address
' Module Desc: O1 address master data management
' Module Methods:
' - O1_Import
' - O1_Export
' - O1_SortDataRowsByC
' - O1_ToggleAutoFilter
' - Import
' - Export
' - SortData
' - ToggleAutoFilter
' ============================================================
Sub O1_Import()
Private Sub Import()
Dim filePath As String
Dim lines As Variant
Dim i As Long
@@ -47,14 +47,14 @@ ErrorHandler:
MsgBox "Import fails:" & vbCrLf & Err.Description, vbCritical
End Sub
Sub O1_SortDataRowsByC()
Private Sub Do_Sort()
Call SortDataRows(3)
End Sub
Sub O1_ToggleAutoFilter()
Private Sub Do_Filter()
Call ToggleAutoFilter(3, 5)
End Sub
Sub O1_AutoFitColumnWidth()
Private Sub Do_Fit()
Call AutoFitColumnWidth(3, 5)
End Sub

18
src/thisWorkbook/Master_O2_507.bas → src/sheet/O2.cls
View File

@@ -1,25 +1,25 @@
' ============================================================
' Module Name: Master_O2_507
' Module Name: Master_507
' Module Desc: O2 master data management (507)
' Module Methods:
' - O2_Import
' - O2_Export
' - O2_SortDataRowsByC
' - O2_ToggleAutoFilter
' - Import
' - Export
' - SortData
' - ToggleAutoFilter
' ============================================================
' ====== (507) =======
Sub O2_Import()
Private Sub Import()
Call Generic_Master_Import(Me, 13)
End Sub
Sub O2_SortDataRowsByC()
Private Sub Do_Sort()
Call SortDataRows(3)
End Sub
Sub O2_ToggleAutoFilter()
Private Sub Do_Filter()
Call ToggleAutoFilter(3, 15)
End Sub
Sub O2_AutoFitColumnWidth()
Private Sub Do_Fit()
Call AutoFitColumnWidth(3, 15)
End Sub

24
src/thisWorkbook/Master_Z1_222.bas → src/sheet/Z1.cls
View File

@@ -1,11 +1,11 @@
' ============================================================
' Module Name: Master_Z1_222
' Module Name: Master_222
' Module Desc: Z1 master data management (222)
' Module Methods:
' - Z1_Import
' - Z1_Export
' - Z1_SortDataRowsByC
' - Z1_ToggleAutoFilter
' - Import
' - Export
' - SortData
' - ToggleAutoFilter
' ============================================================
' ====== (222) =======
@@ -15,11 +15,11 @@ Const END_COL As Long = 9
Const ERROR_COL As Long = 2
' ====== Function ======
Sub Z1_Import()
Private Sub Import()
Call Generic_Master_Import(Me, 7)
End Sub
Sub Z1_Export()
Private Sub Export()
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
If lastDataRow < 7 Then
@@ -43,7 +43,7 @@ Sub Z1_Export()
Call Generic_Master_Export(Me, 7, lastDataRow)
End Sub
Sub Validate(ByVal rowNum As Long)
Private Sub validate(ByVal rowNum As Long)
Set ws = Me
Dim cValue As String: cValue = Trim(ws.Cells(rowNum, 3).Value)
@@ -143,7 +143,7 @@ Sub Validate(ByVal rowNum As Long)
ws.Cells(rowNum, 2).ClearContents
End Sub
Sub Z1_validateButton()
Private Sub validateButton()
Dim lastDataRow As Long, r As Long, errorCount As Long
lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
@@ -168,14 +168,14 @@ Sub Z1_validateButton()
MsgBox "Validation complete. Errors: " & errorCount, vbInformation
End Sub
Sub Z1_SortDataRowsByC()
Private Sub Do_Sort()
Call SortDataRows(3)
End Sub
Sub Z1_ToggleAutoFilter()
Private Sub Do_Filter()
Call ToggleAutoFilter(2, END_COL)
End Sub
Sub Z1_AutoFitColumnWidth()
Private Sub Do_Fit()
Call AutoFitColumnWidth(2, END_COL)
End Sub

24
src/thisWorkbook/Master_Z2_223.bas → src/sheet/Z2.cls
View File

@@ -1,11 +1,11 @@
' ============================================================
' Module Name: Master_Z2_223
' Module Name: Master_223
' Module Desc: Z2 master data management (223)
' Module Methods:
' - Z2_Import
' - Z2_Export
' - Z2_SortDataRowsByC
' - Z2_ToggleAutoFilter
' - Import
' - Export
' - SortData
' - ToggleAutoFilter
' ============================================================
' ====== (223) =======
@@ -15,11 +15,11 @@ Const END_COL As Long = 7
Const ERROR_COL As Long = 2
' ====== Function ======
Sub Z2_Import()
Private Sub Import()
Call Generic_Master_Import(Me, 5)
End Sub
Sub Z2_Export()
Private Sub Export()
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
If lastDataRow < 7 Then
@@ -43,7 +43,7 @@ Sub Z2_Export()
Call Generic_Master_Export(Me, 5, lastDataRow)
End Sub
Sub Validate(ByVal rowNum As Long)
Private Sub validate(ByVal rowNum As Long)
Set ws = Me
Dim cValue As String: cValue = Trim(ws.Cells(rowNum, 3).Value)
@@ -127,7 +127,7 @@ Sub Validate(ByVal rowNum As Long)
ws.Cells(rowNum, 2).ClearContents
End Sub
Sub Z2_validateButton()
Private Sub validateButton()
Dim lastDataRow As Long, r As Long, errorCount As Long
lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
@@ -152,14 +152,14 @@ Sub Z2_validateButton()
MsgBox "Validation complete. Errors: " & errorCount, vbInformation
End Sub
Sub Z2_SortDataRowsByC()
Private Sub Do_Sort()
Call SortDataRows(3)
End Sub
Sub Z2_ToggleAutoFilter()
Private Sub Do_Filter()
Call ToggleAutoFilter(2, END_COL)
End Sub
Sub Z2_AutoFitColumnWidth()
Private Sub Do_Fit()
Call AutoFitColumnWidth(2, END_COL)
End Sub

14
src/thisWorkbook/Master_Z3_224.bas → src/sheet/Z3.cls
View File

@@ -15,11 +15,11 @@ Const END_COL As Long = 8
Const ERROR_COL As Long = 2
' ====== Function ======
Sub Z3_Import()
Private Sub Import()
Call Generic_Master_Import(Me, 6)
End Sub
Sub Z3_Export()
Private Sub Export()
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
If lastDataRow < 7 Then
@@ -43,7 +43,7 @@ Sub Z3_Export()
Call Generic_Master_Export(Me, 6, lastDataRow)
End Sub
Sub Validate(ByVal rowNum As Long)
Private Sub validate(ByVal rowNum As Long)
Set ws = Me
Dim cValue As String: cValue = Trim(ws.Cells(rowNum, 3).Value)
@@ -135,7 +135,7 @@ Sub Validate(ByVal rowNum As Long)
ws.Cells(rowNum, 2).ClearContents
End Sub
Sub Z3_validateButton()
Private Sub validateButton()
Dim lastDataRow As Long, r As Long, errorCount As Long
lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
@@ -160,14 +160,14 @@ Sub Z3_validateButton()
MsgBox "Validation complete. Errors: " & errorCount, vbInformation
End Sub
Sub Z3_SortDataRowsByC()
Private Sub Do_Sort()
Call SortDataRows(3)
End Sub
Sub Z3_ToggleAutoFilter()
Private Sub Do_Filter()
Call ToggleAutoFilter(2, END_COL)
End Sub
Sub Z3_AutoFitColumnWidth()
Private Sub Do_Fit()
Call AutoFitColumnWidth(2, END_COL)
End Sub

14
src/thisWorkbook/Master_Z4_220.bas → src/sheet/Z4.cls
View File

@@ -15,11 +15,11 @@ Const END_COL As Long = 9
Const ERROR_COL As Long = 2
' ====== Function ======
Sub Z4_Import()
Private Sub Import()
Call Generic_Master_Import(Me, 7)
End Sub
Sub Z4_Export()
Private Sub Export()
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
If lastDataRow < 7 Then
@@ -43,7 +43,7 @@ Sub Z4_Export()
Call Generic_Master_Export(Me, 7, lastDataRow)
End Sub
Sub Validate(ByVal rowNum As Long)
Private Sub validate(ByVal rowNum As Long)
Set ws = Me
Dim cValue As String: cValue = Trim(ws.Cells(rowNum, 3).Value)
@@ -135,7 +135,7 @@ Sub Validate(ByVal rowNum As Long)
ws.Cells(rowNum, 2).ClearContents
End Sub
Sub Z4_validateButton()
Private Sub validateButton()
Dim lastDataRow As Long, r As Long, errorCount As Long
lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
@@ -160,14 +160,14 @@ Sub Z4_validateButton()
MsgBox "Validation complete. Errors: " & errorCount, vbInformation
End Sub
Sub Z4_SortDataRowsByC()
Private Sub Do_Sort()
Call SortDataRows(3)
End Sub
Sub Z4_ToggleAutoFilter()
Private Sub Do_Filter()
Call ToggleAutoFilter(2, END_COL)
End Sub
Sub Z4_AutoFitColumnWidth()
Private Sub Do_Fit()
Call AutoFitColumnWidth(2, END_COL)
End Sub

81
src/thisWorkbook/Tukin_C1_Action.md
View File

@@ -1,81 +0,0 @@
# Tukin_C1 ユーザーアクションドキュメント
## 列アクションのマッピング
### C列 (職員番号)
- **トリガー条件**: C列 >= 第7行、内容変化
- **アクション**:
- 内容が空 → `ClearRowData` で一行クリア
- 内容あり → `FillAddressFromO1` で住所ドロップダウン + 4区間の交通機関ドロップダウン生成
---
### 区間1
| 列 | アクション | トリガー条件 | 処理ロジック |
|---|---|---|---|
| **T** (交通機関) | 交通機関ドロップダウン変化 | Column=20 | `CreateZ1StationDropdown` → U列(発)ドロップダウン生成 |
| **U** (利用区間発) | 発ドロップダウン変化 | Column=21 | `CreateM1KukanDDropdown` → V列(着)ドロップダウン生成 |
| **S** (区間コード) | 区間コード入力 | Column=19 | T列ドロップダウン生成 → T列値ありの場合U,Vを填充 + W列(券種)ドロップダウン生成 |
| **W** (券種) | 券種ドロップダウン変化 | Column=23 | `CreateM2CodeDropdown` → X列(コード)ドロップダウン生成 |
---
### 区間2
| 列 | アクション | トリガー条件 | 処理ロジック |
|---|---|---|---|
| **AA** (交通機関) | 交通機関ドロップダウン変化 | Column=27 | `CreateZ1StationDropdown` → AB列(発)ドロップダウン生成 |
| **AB** (利用区間発) | 発ドロップダウン変化 | Column=28 | `CreateM1KukanDDropdown` → AC列(着)ドロップダウン生成 |
| **Z** (区間コード) | 区間コード入力 | Column=26 | AA列ドロップダウン生成 → AA列値ありの場合AB,ACを填充 + AD列(券種)ドロップダウン生成 |
| **AD** (券種) | 券種ドロップダウン変化 | Column=30 | `CreateM2CodeDropdown` → AE列(コード)ドロップダウン生成 |
---
### 区間3
| 列 | アクション | トリガー条件 | 処理ロジック |
|---|---|---|---|
| **AH** (交通機関) | 交通機関ドロップダウン変化 | Column=34 | `CreateZ1StationDropdown` → AI列(発)ドロップダウン生成 |
| **AI** (利用区間発) | 発ドロップダウン変化 | Column=35 | `CreateM1KukanDDropdown` → AJ列(着)ドロップダウン生成 |
| **AG** (区間コード) | 区間コード入力 | Column=33 | AH列ドロップダウン生成 → AH列値ありの場合AI,AJを填充 + AK列(券種)ドロップダウン生成 |
| **AK** (券種) | 券種ドロップダウン変化 | Column=37 | `CreateM2CodeDropdown` → AL列(コード)ドロップダウン生成 |
---
### 区間4
| 列 | アクション | トリガー条件 | 処理ロジック |
|---|---|---|---|
| **AO** (交通機関) | 交通機関ドロップダウン変化 | Column=41 | `CreateZ1StationDropdown` → AP列(発)ドロップダウン生成 |
| **AP** (利用区間発) | 発ドロップダウン変化 | Column=42 | `CreateM1KukanDDropdown` → AQ列(着)ドロップダウン生成 |
| **AN** (区間コード) | 区間コード入力 | Column=40 | AO列ドロップダウン生成 → AO列値ありの場合AP,AQを填充 + AR列(券種)ドロップダウン生成 |
| **AR** (券種) | 券種ドロップダウン変化 | Column=44 | `CreateM2CodeDropdown` → AS列(コード)ドロップダウン生成 |
---
## メソッド一覧
| メソッド名 | 機能 |
|---|---|
| `FillAddressFromO1` | 職員番号(C列)をキーとしてO1キャッシュから住所(I列)ドロップダウン生成 |
| `CreateZ1TransportDropdown` | 交通機関ドロップダウン生成 |
| `CreateZ1StationDropdown` | 交通機関をキーとしてZ1キャッシュから発ドロップダウン生成 |
| `CreateM1KukanDDropdown` | 交通機関+発をキーとしてM1KukanDキャッシュから着ドロップダウン生成 |
| `FillKukanFromM1` | 区間コードをキーとしてM1キャッシュから区間情報(T/U/V等)填充 |
| `CreateM2Dropdown` | 区間コードをキーとして券種ドロップダウン生成 |
| `CreateM2CodeDropdown` | 区間コード+券種をキーとしてコードドロップダウン生成 |
| `ClearRowData` | 一行データクリア |
| `ClearKukanValidation` | 指定列の検証ドロップダウンをクリア |
---
## キャッシュ依存
| キャッシュ | 用途 |
|---|---|
| `o1Cache` | 職員番号 → 住所 |
| `z1Cache` | 交通機関 → 駅 |
| `m1KukanDCache` | 交通機関+発 → 着 |
| `m1Cache` | 区間コード → 区間情報 |
| `m2Cache` | 区間コード+券種 → コード |

71
src/thisWorkbook/Tukin_C1_Mapping.md
View File

@@ -1,71 +0,0 @@
### 届出情報
|列|C列|D列|E列|F列|G列|H列|
|--------|--------|--------|--------|--------|--------|--------|
|ヘッダ|職員番号|事実発生年月日|提出年月日|受理年月日|届出の事由コード|届出の備考|
|データ型|8|日付|日付|日付|Enum|文字列|
### 住所情報
|列|I列|J列|
|--------|--------|--------|
|ヘッダ|住所１|住所２|
|データ型|文字列|文字列|
### 出勤情報
|列|K列|L列|M列|N列|O列|
|--------|--------|--------|--------|--------|--------|
|ヘッダ|運賃改正・法改正年月日|出勤予定日数|往復区分|交替制|算出式|
|データ型|日付|数字|Enum|Enum|文字列|
### 自動車等情報
|列|P列|Q列|R列|
|--------|--------|--------|--------|
|ヘッダ|自動車等使用距離|自動車等支給額|自動車等駐車場代|
|データ型|数字|数字|数字|
### 区間１情報
|列|S列|T列|U列|V列|W列|X列|Y列|
|--------|--------|--------|--------|--------|--------|--------|--------|
|ヘッダ|区間１区間コード|区間１交通機関|区間１発|区間１着|区間１券種|区間１コード|区間１支給開始年月|
|データ型|5|3|文字列|文字列|Enum|3|日付|
### 区間２情報
|列|Z列|AA列|AB列|AC列|AD列|AE列|AF列|
|--------|--------|--------|--------|--------|--------|--------|--------|
|ヘッダ|区間２区間コード|区間２交通機関|区間２発|区間２着|区間２券種|区間２コード|区間２支給開始年月|
|データ型|5|3|文字列|文字列|Enum|3|日付|
### 区間３情報
|列|AG列|AH列|AI列|AJ列|AK列|AL列|AM列|
|--------|--------|--------|--------|--------|--------|--------|--------|
|ヘッダ|区間３区間コード|区間３交通機関|区間３発|区間３着|区間３券種|区間３コード|区間３支給開始年月|
|データ型|5|3|文字列|文字列|Enum|3|日付|
### 区間４情報
|列|AN列|AO列|AP列|AQ列|AR列|AS列|AT列|
|--------|--------|--------|--------|--------|--------|--------|--------|
|ヘッダ|区間４区間コード|区間４交通機関|区間４発|区間４着|区間４券種|区間４コード|区間４支給開始年月|
|データ型|5|3|文字列|文字列|Enum|3|日付|
### 決定事項情報
|列|AU列|AV列|AW列|AX列|
|--------|--------|--------|--------|--------|
|ヘッダ|決定事項区分コード|非該当の理由|非該当者認定簿出力区分|手当月額の決定区分コード|
|データ型|Enum|文字列|Enum|Enum|
### 備考情報
|列|AY列|AZ列|BA列|
|--------|--------|--------|--------|
|ヘッダ|支給の始期|備考|所属コード|
|データ型|日付|文字列|文字列|
### 認定情報
|列|BB列|BC列|
|--------|--------|--------|
|ヘッダ|認定年月日|（各庁の長）官職コード|
|データ型|日付|ENUM|
### エラーメッセージ
|列|BD列|
|--------|--------|
|ヘッダ|エラーメッセージ|
|データ型|文字列|

43
src/thisWorkbook/Tukin_Cache_Mapping.md
View File

@@ -1,43 +0,0 @@
# Tukin キャッシュ マッピング
## キャッシュ一覧
### m1Cache
|列|C列|D列|E列|F列|G列|I列|L列|
|--------|--------|--------|--------|--------|--------|--------|--------|
|ヘッダ|区間コード|交通機関区分|交通機関名称|利用区間発名|利用区間着名|券種|運賃|
### m1KukanDCache
|列|D列|F列|G列|
|--------|--------|--------|--------|
|ヘッダ|交通機関区分|利用区間発名|利用区間着名|
### m2Cache
|列|C列|I列|J列|K列|
|--------|--------|--------|--------|--------|
|ヘッダ|区間コード|券種|コード|名称|
### z1Cache (222)交通機関マスタ
|列|C列|D列|
|--------|--------|--------|
|ヘッダ|区分|交通機関名称|
### z2Cache (223)通勤_決定事項区分一覧
|列|C列|D列|
|--------|--------|--------|
|ヘッダ|区分|決定事項|
### z3Cache (224)通勤_手当月額の決定区分一覧
|列|C列|D列|
|--------|--------|--------|
|ヘッダ|区分|手当月額の決定|
### o1Cache 住所情報
|列|C列|E列|F列|
|--------|--------|--------|--------|
|ヘッダ|職員番号|住所１|住所２|
### o2Cache (507)発信者一覧
|列|C列|D列|
|--------|--------|--------|
|ヘッダ|区分|官職名称|