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

0
src/thisWorkbook/Tukin_C1_Action.md → documents/Tukin_C1_Action.md
View File

0
src/thisWorkbook/Tukin_C1_Mapping.md → documents/Tukin_C1_Mapping.md
View File

0
src/thisWorkbook/Tukin_Cache_Mapping.md → documents/Tukin_Cache_Mapping.md
View File

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

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

@@ -1,254 +1,303 @@
' ============================================================ Attribute VB_Name = "Common_Functions"
' Module Name: Module_Common Option Explicit
' Module Desc: Common utility functions for all modules ' ============================================================
' Module Methods: ' Module Name: Module_Common
' - GetLastDataRowInRange ' Module Desc: Common utility functions for all modules
' - ClearDataRows ' Module Methods:
' - ClearDataRow ' - GetLastDataRowInRange
' - SortDataRows ' - ClearDataRows
' - ToggleAutoFilter ' - ClearDataRow
' - AutoFitColumnWidth ' - SortDataRows
' - GetSaveCSVPath ' - ToggleAutoFilter
' ============================================================ ' - AutoFitColumnWidth
' ============================================================
' Common Functions
' 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 ' Get CSV header from specified row and columns
Dim colCount As Long: colCount = UBound(colLetters) - LBound(colLetters) + 1 Function GetCSVHeader(ByVal ws As Worksheet, ByVal colLetters As Variant, ByVal headerRow As Long) As Variant
Dim headerArr() As String Dim colCount As Long: colCount = UBound(colLetters) - LBound(colLetters) + 1
ReDim headerArr(1 To 1, 1 To colCount) Dim headerArr() As String
ReDim headerArr(1 To 1, 1 To colCount)
Dim i As Long
Dim cellValue As String Dim i As Long
For i = 0 To colCount - 1 Dim cellValue As String
cellValue = Trim(ws.Cells(headerRow, Columns(colLetters(i)).Column).Value) For i = 0 To colCount - 1
cellValue = Replace(cellValue, vbLf, "") cellValue = Trim(ws.Cells(headerRow, Columns(colLetters(i)).Column).Value)
cellValue = Replace(cellValue, vbCr, "") cellValue = Replace(cellValue, vbLf, "")
cellValue = Replace(cellValue, vbCrLf, "") cellValue = Replace(cellValue, vbCr, "")
headerArr(1, i + 1) = cellValue cellValue = Replace(cellValue, vbCrLf, "")
Next i headerArr(1, i + 1) = cellValue
Next i
GetCSVHeader = headerArr
End Function GetCSVHeader = headerArr
End Function
Function CleanCSVField(ByVal inputStr As String) As String
Dim s As String Function CleanCSVField(ByVal inputStr As String) As String
s = Trim(inputStr) Dim s As String
s = Trim(inputStr)
' calcute
If Len(s) > 0 Then ' calcute
Select Case Left(s, 1) If Len(s) > 0 Then
Case "=", "+", "-", "@" Select Case Left(s, 1)
CleanCSVField = "'" & s Case "=", "+", "-", "@"
Exit Function CleanCSVField = "'" & s
End Select Exit Function
End If End Select
End If
CleanCSVField = s
End Function 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 Function GetLastDataRow(ByVal ws As Worksheet, ByVal columnNum As Long) As Long
End Function GetLastDataRow = ws.Cells(ws.Rows.Count, columnNum).End(xlUp).Row
End Function
' @return dict : key = keyCol，value = Array
' @param sheetName ' @return dict : key = keyCol，value = Array
' @param keyCol ' @param sheetName
' @param valueCols Array(4,5,6) ' @param keyCol
' @param startRow default is 7 ' @param valueCols Array(4,5,6)
Function LoadLookup( _ ' @param startRow default is 7
ByVal sheetName As String, _ Function LoadLookup( _
ByVal keyCol As Long, _ ByVal sheetName As String, _
ByVal valueCols As Variant, _ ByVal keyCol As Long, _
Optional ByVal startRow As Long = 7 _ ByVal valueCols As Variant, _
) As Object Optional ByVal startRow As Long = 7 _
) As Object
' --- validate ---
If Trim(sheetName) = "" Then Exit Function ' --- validate ---
If Not IsArray(valueCols) Then If Trim(sheetName) = "" Then Exit Function
valueCols = Array(valueCols) If Not IsArray(valueCols) Then
End If valueCols = Array(valueCols)
Dim nValCols As Long: nValCols = UBound(valueCols) - LBound(valueCols) + 1 End If
If nValCols = 0 Then Exit Function Dim nValCols As Long: nValCols = UBound(valueCols) - LBound(valueCols) + 1
If nValCols = 0 Then Exit Function
' --- obtain worksheet ---
On Error Resume Next ' --- obtain worksheet ---
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(sheetName) On Error Resume Next
On Error GoTo 0 Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(sheetName)
If ws Is Nothing Then Exit Function 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 ' --- obtain data（based on keyCol）---
If lastRow < startRow Then Exit Function 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 ' --- prepare col ---
Dim maxCol As Long: maxCol = keyCol Dim minCol As Long: minCol = keyCol
Dim i As Long Dim maxCol As Long: maxCol = keyCol
For i = LBound(valueCols) To UBound(valueCols) Dim i As Long
If Not IsNumeric(valueCols(i)) Then Exit Function For i = LBound(valueCols) To UBound(valueCols)
Dim colNum As Long: colNum = CLng(valueCols(i)) If Not IsNumeric(valueCols(i)) Then Exit Function
If colNum < 1 Then Exit Function Dim colNum As Long: colNum = CLng(valueCols(i))
If colNum < minCol Then minCol = colNum If colNum < 1 Then Exit Function
If colNum > maxCol Then maxCol = colNum If colNum < minCol Then minCol = colNum
Next i If colNum > maxCol Then maxCol = colNum
Next i
' --- read ---
Dim dataRange As Range ' --- read ---
Set dataRange = ws.Range(ws.Cells(startRow, minCol), ws.Cells(lastRow, maxCol)) Dim dataRange As Range
Dim data As Variant: data = dataRange.Value 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 ' --- Ensure data is a 2D array ---
' Single cell case If Not IsArray(data) Then
Dim temp As Variant ' Single cell case
ReDim temp(1 To 1, 1 To (maxCol - minCol + 1)) Dim temp As Variant
temp(1, 1) = data ReDim temp(1 To 1, 1 To (maxCol - minCol + 1))
data = temp temp(1, 1) = data
End If data = temp
End If
' --- build ---
Dim keyOffset As Long: keyOffset = keyCol - minCol + 1 ' --- build ---
Dim valOffsets() As Long: ReDim valOffsets(0 To nValCols - 1) Dim keyOffset As Long: keyOffset = keyCol - minCol + 1
For i = 0 To nValCols - 1 Dim valOffsets() As Long: ReDim valOffsets(0 To nValCols - 1)
valOffsets(i) = valueCols(LBound(valueCols) + i) - minCol + 1 For i = 0 To nValCols - 1
Next i valOffsets(i) = valueCols(LBound(valueCols) + i) - minCol + 1
Next i
' --- write into ---
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary") ' --- write into ---
dict.CompareMode = vbTextCompare Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim r As Long
For r = 1 To UBound(data, 1) Dim r As Long
Dim key As String: key = Trim(data(r, keyOffset)) For r = 1 To UBound(data, 1)
If key <> "" Then Dim key As String: key = Trim(data(r, keyOffset))
Dim vals() As String: ReDim vals(0 To nValCols - 1) If key <> "" Then
Dim j As Long Dim vals() As String: ReDim vals(0 To nValCols - 1)
For j = 0 To nValCols - 1 Dim j As Long
vals(j) = Trim(data(r, valOffsets(j))) For j = 0 To nValCols - 1
Next j vals(j) = Trim(data(r, valOffsets(j)))
dict(key) = vals Next j
End If dict(key) = vals
Next r End If
Next r
Set LoadLookup = dict
End Function 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 --- ' obtain
If startCol < 1 Then Function GetLastDataRowInRange(ws As Worksheet) As Long
Err.Raise 1001, "GetLastDataRowInRange", "startCol must >= 1"
End If If dataRangeDict Is Nothing Then Call RefreshDataRangeDict
If endCol < 1 Then
Err.Raise 1002, "GetLastDataRowInRange", "endCol must >= 1" If dataRangeDict.Exists(ws.CodeName) Then
End If Dim dataRange As Variant: dataRange = dataRangeDict(ws.CodeName)
If endCol < startCol Then
Err.Raise 1003, "GetLastDataRowInRange", "endCol must >= startCol" Dim startCol As Long, endCol As Long, startRow As Long
End If On Error GoTo InvalidColumn
If startRow < 1 Then startCol = ws.Range(dataRange(0) & "1").Column
Err.Raise 1004, "GetLastDataRowInRange", "startRow must >= 1" endCol = ws.Range(dataRange(1) & "1").Column
End If startRow = dataRange(3)
On Error GoTo 0
' --- query max row ---
Dim colIndex As Long, lastRow As Long, maxRow As Long ' --- query max row ---
Dim colIndex As Long, lastRow As Long, maxRow As Long
maxRow = startRow - 1
For colIndex = startCol To endCol maxRow = startRow - 1
lastRow = ws.Cells(ws.Rows.Count, colIndex).End(xlUp).Row For colIndex = startCol To endCol
If lastRow > maxRow Then maxRow = lastRow lastRow = ws.Cells(ws.Rows.Count, colIndex).End(xlUp).Row
Next colIndex If lastRow > maxRow Then maxRow = lastRow
Next colIndex
GetLastDataRowInRange = maxRow
End Function GetLastDataRowInRange = maxRow
Else
Function ClearDataRow(ByVal ws As Worksheet, ByVal startCol As Long, ByVal endCol As Long, ByVal rowRow As Long, Optional ByVal errorCol As Long = 2) Err.Raise 1004, "GetLastDataRowInRange", "Sheet not configured: " & ws.CodeName
If rowRow >= 7 Then End If
Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowRow, startCol), ws.Cells(rowRow, endCol)) Exit Function
clearRange.ClearContents
clearRange.Interior.Color = vbWhite InvalidColumn:
ws.Range(ws.Cells(rowRow, errorCol), ws.Cells(rowRow, errorCol)).ClearContents Err.Raise 1005, "GetLastDataRowInRange", "Invalid column letter for sheet: " & ws.CodeName
End If End Function
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)
Function ClearDataRows(ByVal ws As Worksheet, ByVal startCol As Long, ByVal endCol As Long, Optional ByVal startRow As Long = 7) If rowRow >= 7 Then
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws, startCol, endCol, startRow) Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowRow, startCol), ws.Cells(rowRow, endCol))
clearRange.ClearContents
If lastDataRow >= startRow Then clearRange.Interior.Color = vbWhite
Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(startRow, startCol), ws.Cells(lastDataRow, endCol)) ws.Range(ws.Cells(rowRow, errorCol), ws.Cells(rowRow, errorCol)).ClearContents
clearRange.ClearContents End If
clearRange.Interior.Color = vbWhite End Function
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)
Sub SortDataRows(Optional ByVal sortColumn As Long = 3)
Dim ws As Worksheet If lastDataRow >= startRow Then
Dim lastRow As Long Dim clearRange As Range: Set clearRange = ws.Range(ws.Cells(startRow, startCol), ws.Cells(lastDataRow, endCol))
Dim startRow As Long clearRange.ClearContents
Dim sortOrder As Long clearRange.Interior.Color = vbWhite
End If
Set ws = ActiveSheet End Function
startRow = 7
lastRow = GetLastDataRow(ws, sortColumn) Sub SortDataRows(Optional ByVal sortColumn As Long = 3)
Dim ws As Worksheet
If lastRow < startRow Then Dim lastRow As Long
MsgBox "No data to sort.", vbExclamation Dim startRow As Long
Exit Sub Dim sortOrder As Long
End If
Set ws = ActiveSheet
' Determine sort order based on first row's current state startRow = 7
Dim currentFirst As String lastRow = GetLastDataRow(ws, sortColumn)
Dim nextFirst As String
currentFirst = Trim(ws.Cells(startRow, sortColumn).Value) If lastRow < startRow Then
nextFirst = Trim(ws.Cells(startRow + 1, sortColumn).Value) MsgBox "No data to sort.", vbExclamation
Exit Sub
If currentFirst <> "" And nextFirst <> "" Then End If
If currentFirst > nextFirst Then
sortOrder = xlAscending ' Determine sort order based on first row's current state
Else Dim currentFirst As String
sortOrder = xlDescending Dim nextFirst As String
End If currentFirst = Trim(ws.Cells(startRow, sortColumn).Value)
Else nextFirst = Trim(ws.Cells(startRow + 1, sortColumn).Value)
sortOrder = xlAscending
End If If currentFirst <> "" And nextFirst <> "" Then
If currentFirst > nextFirst Then
ws.Range(ws.Cells(startRow, 1), ws.Cells(lastRow, 20)).Sort _ sortOrder = xlAscending
Key1:=ws.Cells(startRow, sortColumn), _ Else
Order1:=sortOrder, _ sortOrder = xlDescending
Header:=xlNo End If
End Sub Else
sortOrder = xlAscending
Sub ToggleAutoFilter(ByVal startColumn As Long, ByVal endColumn As Long, Optional ByVal filterRow As Long = 6) End If
Dim ws As Worksheet: Set ws = ActiveSheet
ws.Range(ws.Cells(startRow, 1), ws.Cells(lastRow, 20)).Sort _
' Check if auto filter is already on Key1:=ws.Cells(startRow, sortColumn), _
If ws.AutoFilterMode Then Order1:=sortOrder, _
ws.AutoFilterMode = False Header:=xlNo
Exit Sub End Sub
End If
If startColumn < 1 Or endColumn < startColumn Then Exit Sub Sub ToggleAutoFilter(ByVal startColumn As Long, ByVal endColumn As Long, Optional ByVal filterRow As Long = 6)
Dim filterRange As Range: Set filterRange = ws.Range(ws.Cells(filterRow, startColumn), ws.Cells(filterRow, endColumn)) Dim ws As Worksheet: Set ws = ActiveSheet
filterRange.AutoFilter
End Sub ' Check if auto filter is already on
If ws.AutoFilterMode Then
Sub AutoFitColumnWidth(ByVal fitColumnStart As Long, ByVal fitColumnEnd As Long) ws.AutoFilterMode = False
Dim ws As Worksheet: Set ws = ActiveSheet Exit Sub
If fitColumnStart <= fitColumnEnd Then End If
ws.Range(ws.Columns(fitColumnStart), ws.Columns(fitColumnEnd)).AutoFit If startColumn < 1 Or endColumn < startColumn Then Exit Sub
End If Dim filterRange As Range: Set filterRange = ws.Range(ws.Cells(filterRow, startColumn), ws.Cells(filterRow, endColumn))
End Sub filterRange.AutoFilter
End Sub
' Format: code:value (no space around colon)
Function MakeSelect(ByVal code As String, ByVal value As String) As String Sub AutoFitColumnWidth(ByVal fitColumnStart As Long, ByVal fitColumnEnd As Long)
MakeSelect = Trim(code) & ":" & Trim(value) Dim ws As Worksheet: Set ws = ActiveSheet
End Function If fitColumnStart <= fitColumnEnd Then
ws.Range(ws.Columns(fitColumnStart), ws.Columns(fitColumnEnd)).AutoFit
' Get left part of MakeSelect format (e.g., "1:JR" -> "1") End If
Function GetCode(ByVal text As String) As String End Sub
Dim pos As Long: pos = InStr(text, ":")
If pos > 0 Then ' Format: code:value (no space around colon)
GetCode = Left(text, pos - 1) Function MakeSelect(ByVal code As String, ByVal value As String) As String
Else MakeSelect = Trim(code) & ":" & Trim(value)
GetCode = text End Function
End If
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 Name: Generic_Master_Common
' Module Desc: Generic Master Import/Export functions ' 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 Name: Global_Cache
' Module Desc: Global Cache Module, Shared caches across all worksheets ' Module Desc: Global Cache Module, Shared caches across all worksheets
' Module Methods: ' Module Methods:
' - RefreshM1Cache / ClearM1Cache ' - RefreshM1Cache
' - RefreshM1KukanDCache / ClearM1KukanDCache ' - RefreshM1KukanDCache
' - RefreshM2Cache / ClearM2Cache ' - RefreshM2Cache
' - RefreshZ1Cache / ClearZ1Cache ' - RefreshZ1Cache
' - RefreshZ2Cache / ClearZ2Cache ' - RefreshZ2Cache
' - RefreshZ3Cache / ClearZ3Cache ' - RefreshZ3Cache
' - RefreshO1Cache / ClearO1Cache ' - RefreshO1Cache
' - RefreshO2Cache / ClearO2Cache ' - RefreshO2Cache
' ============================================================ ' ============================================================
' Cache Variables ' Cache Variables
@@ -27,6 +29,8 @@ Public oufukuList As Object
Public koutaiList As Object Public koutaiList As Object
Public higaitouList As Object Public higaitouList As Object
Public dataRangeDict As Object
' m1Cache - used by M2_Kukan_detail, Tukin_C1 ' m1Cache - used by M2_Kukan_detail, Tukin_C1
' m1KukanDCache - nested dict {D: {F: [G]}} ' m1KukanDCache - nested dict {D: {F: [G]}}
' z1Cache - used by M1_Kukan, Tukin_C1 ' z1Cache - used by M1_Kukan, Tukin_C1
@@ -56,10 +60,6 @@ RefreshError:
Err.Raise 1002, "RefreshM1Cache", "Failed to load M1 lookup cache: " & Err.Description Err.Raise 1002, "RefreshM1Cache", "Failed to load M1 lookup cache: " & Err.Description
End Sub End Sub
Public Sub ClearM1Cache()
Set m1Cache = Nothing
End Sub
' Refresh M1_KukanD cache - nested dict {D: {F: [G]}} ' Refresh M1_KukanD cache - nested dict {D: {F: [G]}}
' Structure: { 交通機関区分[D]: { 利用区間発名[F]: [利用区間着名G] } } ' Structure: { 交通機関区分[D]: { 利用区間発名[F]: [利用区間着名G] } }
Public Sub RefreshM1KukanDCache() Public Sub RefreshM1KukanDCache()
@@ -105,10 +105,6 @@ NextRow2:
Next r Next r
End Sub End Sub
Public Sub ClearM1KukanDCache()
Set m1KukanDCache = Nothing
End Sub
' ============================================================ ' ============================================================
' M2 Cache - Nested Dictionary ' M2 Cache - Nested Dictionary
' Structure: { 区間コード[C]: { 券種[I]: { コード[J]: K } } } ' Structure: { 区間コード[C]: { 券種[I]: { コード[J]: K } } }
@@ -158,10 +154,6 @@ NextRow:
Next r Next r
End Sub End Sub
Public Sub ClearM2Cache()
Set m2Cache = Nothing
End Sub
' ============================================================ ' ============================================================
' Z1 Cache ' Z1 Cache
' ============================================================ ' ============================================================
@@ -182,10 +174,6 @@ RefreshError:
Err.Raise 1002, "RefreshZ1Cache", "Failed to load Z1 lookup cache: " & Err.Description Err.Raise 1002, "RefreshZ1Cache", "Failed to load Z1 lookup cache: " & Err.Description
End Sub End Sub
Public Sub ClearZ1Cache()
Set z1Cache = Nothing
End Sub
' ============================================================ ' ============================================================
' Z2 Cache ' Z2 Cache
' ============================================================ ' ============================================================
@@ -206,10 +194,6 @@ RefreshError:
Err.Raise 1002, "RefreshZ2Cache", "Failed to load Z2 lookup cache: " & Err.Description Err.Raise 1002, "RefreshZ2Cache", "Failed to load Z2 lookup cache: " & Err.Description
End Sub End Sub
Public Sub ClearZ2Cache()
Set z2Cache = Nothing
End Sub
' ============================================================ ' ============================================================
' Z3 Cache ' Z3 Cache
' ============================================================ ' ============================================================
@@ -230,10 +214,6 @@ RefreshError:
Err.Raise 1002, "RefreshZ3Cache", "Failed to load Z3 lookup cache: " & Err.Description Err.Raise 1002, "RefreshZ3Cache", "Failed to load Z3 lookup cache: " & Err.Description
End Sub End Sub
Public Sub ClearZ3Cache()
Set z3Cache = Nothing
End Sub
' ============================================================ ' ============================================================
' z4Cache ' z4Cache
' ============================================================ ' ============================================================
@@ -252,10 +232,6 @@ RefreshError:
Err.Raise 1001, "RefreshZ4Cache", "Failed to load Enum lookup cache: " & Err.Description Err.Raise 1001, "RefreshZ4Cache", "Failed to load Enum lookup cache: " & Err.Description
End Sub End Sub
Public Sub ClearZ4Cache()
Set z4Cache = Nothing
End Sub
' ============================================================ ' ============================================================
' O1 Cache ' O1 Cache
' ============================================================ ' ============================================================
@@ -308,10 +284,6 @@ NextO1:
Next r Next r
End Sub End Sub
Public Sub ClearO1Cache()
Set o1Cache = Nothing
End Sub
' ============================================================ ' ============================================================
' O2 Cache ' O2 Cache
' ============================================================ ' ============================================================
@@ -332,10 +304,6 @@ RefreshError:
Err.Raise 1002, "RefreshO2Cache", "Failed to load O2 lookup cache: " & Err.Description Err.Raise 1002, "RefreshO2Cache", "Failed to load O2 lookup cache: " & Err.Description
End Sub End Sub
Public Sub ClearO2Cache()
Set o2Cache = Nothing
End Sub
' ============================================================ ' ============================================================
' tokubetuList ' tokubetuList
' ============================================================ ' ============================================================
@@ -354,10 +322,6 @@ RefreshError:
Err.Raise 1001, "GetTokubetu", "Failed to load Enum lookup cache: " & Err.Description Err.Raise 1001, "GetTokubetu", "Failed to load Enum lookup cache: " & Err.Description
End Sub End Sub
Public Sub ClearTokubetu()
Set tokubetuList = Nothing
End Sub
' ============================================================ ' ============================================================
' oufukuList ' oufukuList
' ============================================================ ' ============================================================
@@ -376,10 +340,6 @@ RefreshError:
Err.Raise 1001, "GetOufukuList", "Failed to load Enum lookup cache: " & Err.Description Err.Raise 1001, "GetOufukuList", "Failed to load Enum lookup cache: " & Err.Description
End Sub End Sub
Public Sub ClearOufukuList()
Set oufukuList = Nothing
End Sub
' ============================================================ ' ============================================================
' koutaiList ' koutaiList
' ============================================================ ' ============================================================
@@ -398,10 +358,6 @@ RefreshError:
Err.Raise 1001, "GetKoutaiList", "Failed to load Enum lookup cache: " & Err.Description Err.Raise 1001, "GetKoutaiList", "Failed to load Enum lookup cache: " & Err.Description
End Sub End Sub
Public Sub ClearKoutaiList()
Set koutaiList = Nothing
End Sub
' ============================================================ ' ============================================================
' higaitouList ' higaitouList
' ============================================================ ' ============================================================
@@ -420,6 +376,8 @@ RefreshError:
Err.Raise 1001, "GetHigaitouList", "Failed to load Enum lookup cache: " & Err.Description Err.Raise 1001, "GetHigaitouList", "Failed to load Enum lookup cache: " & Err.Description
End Sub End Sub
Public Sub ClearHigaitouList() ' sheetName : [START_COL, END_COL, ERROR_COL, START_ROW, HEADER_ROW, RefaushCacheName]
Set higaitouList = Nothing Public Sub RefreshDataRangeDict()
Set dataRangeDict = CreateObject("Scripting.Dictionary")
dataRangeDict("M1") = Array("C", "N", "O", 7, 5, "RefreshM1Cache")
End Sub 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 Name: Build_Select
' Module Desc: Commuter allowance editing sheet (no CSV import) ' 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 KUKAN_START_DAY_COLS = Array(25, 32, 39, 46) ' Y, AF, AM, AT
End Function 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 ' Helper: Get index by value, return -1 if not found
' ============================================================ ' ============================================================
@@ -88,13 +92,16 @@ Private Sub Worksheet_Change(ByVal Target As Range)
With Me With Me
Set watchArea = Union( _ Set watchArea = Union( _
.Columns("C"), _ .Columns("C"), _
.Columns("D"), _
.Columns("E"), _ .Columns("E"), _
.Columns("F"), _
.Columns("G"), _ .Columns("G"), _
.Columns("I"), _ .Columns("I"), _
.Columns("S:W"), _ .Columns("S:W"), _
.Columns("Z:AD"), _ .Columns("Z:AD"), _
.Columns("AG:AK"), _ .Columns("AG:AK"), _
.Columns("AN:AR") _ .Columns("AN:AR"), _
.Columns("BB") _
) )
End With End With
Dim intersectRng As Range: Set intersectRng = Application.Intersect(Target, watchArea) Dim intersectRng As Range: Set intersectRng = Application.Intersect(Target, watchArea)
@@ -120,6 +127,17 @@ Private Sub Worksheet_Change(ByVal Target As Range)
Next Next
End If 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) === ' === Transport column changes (T, AA, AH, AO) ===
Dim idx As Long Dim idx As Long
idx = GetIdx(Target.Column, KUKAN_TRANSPORT_COLS) idx = GetIdx(Target.Column, KUKAN_TRANSPORT_COLS)
@@ -448,7 +466,7 @@ Private Sub ClearRowData(ByVal rowNum As Long)
End Sub End Sub
' ====== Button Macros ====== ' ====== Button Macros ======
Sub C1_validateButton() Private Sub validateButton()
Dim lastRow As Long, r As Long, errorCount As Long Dim lastRow As Long, r As Long, errorCount As Long
lastRow = GetLastDataRowInRange(Me, START_COL, END_COL) lastRow = GetLastDataRowInRange(Me, START_COL, END_COL)
@@ -469,7 +487,7 @@ Sub C1_validateButton()
End Sub End Sub
' Validation logic ' Validation logic
Private Sub Validate(ByVal rowNum As Long) Private Private Sub validate(ByVal rowNum As Long)
Set ws = Me Set ws = Me
' Clear background color ' Clear background color
@@ -490,14 +508,14 @@ Private Sub Validate(ByVal rowNum As Long)
Me.Cells(rowNum, ERROR_COL).ClearContents Me.Cells(rowNum, ERROR_COL).ClearContents
End Sub End Sub
Sub C1_SortDataRowsByC() Private Sub Do_Sort()
Call SortDataRows(3) Call SortDataRows(3)
End Sub End Sub
Sub C1_ToggleAutoFilter() Private Sub Do_Filter()
Call ToggleAutoFilter(START_COL, END_COL) Call ToggleAutoFilter(START_COL, END_COL)
End Sub End Sub
Sub C1_AutoFitColumnWidth() Private Sub Do_Fit()
Call AutoFitColumnWidth(START_COL, END_COL) Call AutoFitColumnWidth(START_COL, END_COL)
End Sub 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 Desc: M1 Kukan master data management (import/export/validate)
' Module Methods: ' Module Methods:
' - M1_Import ' - Import
' - M1_Export ' - Export
' - M1_validateButton_Click ' - validateButton_Click
' - M1_SortDataRowsByC ' - SortData
' - M1_ToggleAutoFilter ' - ToggleAutoFilter
' - M1_Worksheet_Change ' - Worksheet_Change
' - M1_ValidateRow ' - ValidateRow
' - M1_FillValidationDropdown ' - FillValidationDropdown
' - M1_ValidateAllRows ' - ValidateAllRows
' ============================================================ ' ============================================================
' ====== Constants ====== ' ====== Constants ======
Const START_COL As Long = 3 ' C column Const START_COL As Long = 3 ' C column
Const END_COL As Long = 14 ' N column Const END_COL As Long = 14 ' N column
Const ERROR_COL As Long = 15 ' O 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 Function HEADERS() As Variant
HEADERS = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N") 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 If
End Sub End Sub
Sub M1_Import() Sub Import(wsTarget As Worksheet)
' === Step 1: Select CSV file === ' === Step 1: Select CSV file ===
Dim filePath As String: filePath = SelectCSVFile() Dim filePath As String: filePath = SelectCSVFile()
If filePath = "" Then Exit Sub If filePath = "" Then Exit Sub
@@ -102,7 +102,6 @@ Sub M1_Import()
' === Step 3:Clear all data rows before import === ' === Step 3:Clear all data rows before import ===
Application.EnableEvents = False Application.EnableEvents = False
Dim wsTarget As Worksheet: Set wsTarget = Me
Call ClearDataRows(wsTarget, START_COL, END_COL, 7) Call ClearDataRows(wsTarget, START_COL, END_COL, 7)
Application.EnableEvents = True Application.EnableEvents = True
@@ -126,8 +125,7 @@ ImportError:
MsgBox "CSV import failed: " & Err.Description, vbExclamation MsgBox "CSV import failed: " & Err.Description, vbExclamation
End Sub End Sub
Sub validate(ByVal rowNum As Long, ByVal lastDataRow As Long) Private Sub validate(ws As Worksheet, ByVal rowNum As Long, ByVal lastDataRow As Long)
Set ws = Me
Dim clearRange As Range Dim clearRange As Range
Set clearRange = ws.Range(ws.Cells(rowNum, START_COL), ws.Cells(rowNum, END_COL)) 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 End Sub
' Validate button ' Validate button
Sub M1_validateButton() Sub validateAll(ws As Worksheet)
Dim lastDataRow As Long, r As Long, errorCount As Long 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 If lastDataRow < 7 Then
MsgBox "No data found.", vbExclamation MsgBox "No data found.", vbExclamation
@@ -218,7 +216,7 @@ Sub M1_validateButton()
For r = 7 To lastDataRow For r = 7 To lastDataRow
Validate r, lastDataRow Validate r, lastDataRow
If Trim(Cells(r, ERROR_COL).Value) <> "" Then If Trim(ws.Cells(r, ERROR_COL).Value) <> "" Then
errorCount = errorCount + 1 errorCount = errorCount + 1
End If End If
Next r Next r
@@ -231,7 +229,7 @@ Sub M1_validateButton()
MsgBox "Validation complete. Errors: " & errorCount, vbInformation MsgBox "Validation complete. Errors: " & errorCount, vbInformation
End Sub End Sub
Sub M1_Export() Private Sub Export()
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL) Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
If lastDataRow < 7 Then If lastDataRow < 7 Then
MsgBox "No data rows to output.", vbExclamation MsgBox "No data rows to output.", vbExclamation
@@ -263,7 +261,7 @@ Sub M1_Export()
' === Step 4: Build array with header and data === ' === Step 4: Build array with header and data ===
Dim headerArr As Variant Dim headerArr As Variant
Dim colLetters As Variant: colLetters = HEADERS() Dim colLetters As Variant: colLetters = HEADERS()
headerArr = GetCSVHeader(ws, colLetters, M1_HEADER_ROW) headerArr = GetCSVHeader(ws, colLetters, HEADER_ROW)
Dim outputArr As Variant Dim outputArr As Variant
ReDim outputArr(1 To rowCount + 1, 1 To 12) ReDim outputArr(1 To rowCount + 1, 1 To 12)
@@ -294,14 +292,14 @@ ExportError:
MsgBox "CSV export failed: " & Err.Description, vbExclamation MsgBox "CSV export failed: " & Err.Description, vbExclamation
End Sub End Sub
Sub M1_SortDataRowsByC() Private Sub Do_Sort()
Call SortDataRows(3) Call SortDataRows(3)
End Sub End Sub
Sub M1_ToggleAutoFilter() Private Sub Do_Filter()
Call ToggleAutoFilter(START_COL, END_COL) Call ToggleAutoFilter(START_COL, END_COL)
End Sub End Sub
Sub M1_AutoFitColumnWidth() Private Sub Do_Fit()
Call AutoFitColumnWidth(START_COL, END_COL) Call AutoFitColumnWidth(START_COL, END_COL)
End Sub 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 Desc: M2 Kukan detail master data management
' Module Methods: ' Module Methods:
' - M2_Import ' - Import
' - M2_Export ' - Export
' - M2_validateButton_Click ' - validateButton_Click
' - M2_SortDataRowsByC ' - SortData
' - M2_ToggleAutoFilter ' - ToggleAutoFilter
' - M2_Worksheet_Change ' - Worksheet_Change
' - M2_ValidateRow ' - ValidateRow
' - M2_FillValidationDropdown ' - FillValidationDropdown
' - M2_ValidateAllRows ' - ValidateAllRows
' ============================================================ ' ============================================================
' ====== Constants ====== ' ====== Constants ======
Const START_COL As Long = 3 ' C column Const START_COL As Long = 3 ' C column
Const END_COL As Long = 18 ' R column Const END_COL As Long = 18 ' R column
Const ERROR_COL As Long = 19 ' S 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 Function HEADERS() As Variant
HEADERS = Array("C", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R") 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 ws.Cells(rowNum, 19).ClearContents ' Q column error info
End Sub End Sub
Sub M2_Import() Private Sub Import()
' === Step 1: Select CSV file === ' === Step 1: Select CSV file ===
Dim filePath As String: filePath = SelectCSVFile() Dim filePath As String: filePath = SelectCSVFile()
If filePath = "" Then Exit Sub If filePath = "" Then Exit Sub
@@ -120,7 +120,7 @@ ImportError:
MsgBox "CSV import failed: " & Err.Description, vbExclamation MsgBox "CSV import failed: " & Err.Description, vbExclamation
End Sub 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 Set ws = Me
Dim clearRange As Range Dim clearRange As Range
@@ -171,7 +171,7 @@ Sub validate(ByVal rowNum As Long, ByVal lastDataRow As Long)
End Sub End Sub
' Button macro (Validate selected row) ' Button macro (Validate selected row)
Sub M2_validateButton() Private Sub validateButton()
Dim lastDataRow As Long, r As Long, errorCount As Long Dim lastDataRow As Long, r As Long, errorCount As Long
lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL) lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
@@ -190,7 +190,7 @@ Sub M2_validateButton()
MsgBox "Validation complete. Errors: " & errorCount, vbInformation MsgBox "Validation complete. Errors: " & errorCount, vbInformation
End Sub End Sub
Sub M2_Export() Private Sub Export()
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL) Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
If lastDataRow < 7 Then If lastDataRow < 7 Then
MsgBox "No data rows to output.", vbExclamation MsgBox "No data rows to output.", vbExclamation
@@ -222,7 +222,7 @@ Sub M2_Export()
' === Step 4: Build array with header and data === ' === Step 4: Build array with header and data ===
Dim headerArr As Variant Dim headerArr As Variant
Dim colLetters As Variant: colLetters = HEADERS() Dim colLetters As Variant: colLetters = HEADERS()
headerArr = GetCSVHeader(ws, colLetters, M2_HEADER_ROW) headerArr = GetCSVHeader(ws, colLetters, HEADER_ROW)
Dim outputArr As Variant Dim outputArr As Variant
ReDim outputArr(1 To rowCount + 1, 1 To 11) ReDim outputArr(1 To rowCount + 1, 1 To 11)
@@ -254,14 +254,14 @@ ExportError:
End Sub End Sub
Sub M2_SortDataRowsByC() Private Sub Do_Sort()
Call SortDataRows(3) Call SortDataRows(3)
End Sub End Sub
Sub M2_ToggleAutoFilter() Private Sub Do_Filter()
Call ToggleAutoFilter(START_COL, END_COL) Call ToggleAutoFilter(START_COL, END_COL)
End Sub End Sub
Sub M2_AutoFitColumnWidth() Private Sub Do_Fit()
Call AutoFitColumnWidth(START_COL, END_COL) Call AutoFitColumnWidth(START_COL, END_COL)
End Sub 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 Desc: O1 address master data management
' Module Methods: ' Module Methods:
' - O1_Import ' - Import
' - O1_Export ' - Export
' - O1_SortDataRowsByC ' - SortData
' - O1_ToggleAutoFilter ' - ToggleAutoFilter
' ============================================================ ' ============================================================
Sub O1_Import() Private Sub Import()
Dim filePath As String Dim filePath As String
Dim lines As Variant Dim lines As Variant
Dim i As Long Dim i As Long
@@ -47,14 +47,14 @@ ErrorHandler:
MsgBox "Import fails:" & vbCrLf & Err.Description, vbCritical MsgBox "Import fails:" & vbCrLf & Err.Description, vbCritical
End Sub End Sub
Sub O1_SortDataRowsByC() Private Sub Do_Sort()
Call SortDataRows(3) Call SortDataRows(3)
End Sub End Sub
Sub O1_ToggleAutoFilter() Private Sub Do_Filter()
Call ToggleAutoFilter(3, 5) Call ToggleAutoFilter(3, 5)
End Sub End Sub
Sub O1_AutoFitColumnWidth() Private Sub Do_Fit()
Call AutoFitColumnWidth(3, 5) Call AutoFitColumnWidth(3, 5)
End Sub 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 Desc: O2 master data management (507)
' Module Methods: ' Module Methods:
' - O2_Import ' - Import
' - O2_Export ' - Export
' - O2_SortDataRowsByC ' - SortData
' - O2_ToggleAutoFilter ' - ToggleAutoFilter
' ============================================================ ' ============================================================
' ====== (507) ======= ' ====== (507) =======
Sub O2_Import() Private Sub Import()
Call Generic_Master_Import(Me, 13) Call Generic_Master_Import(Me, 13)
End Sub End Sub
Sub O2_SortDataRowsByC() Private Sub Do_Sort()
Call SortDataRows(3) Call SortDataRows(3)
End Sub End Sub
Sub O2_ToggleAutoFilter() Private Sub Do_Filter()
Call ToggleAutoFilter(3, 15) Call ToggleAutoFilter(3, 15)
End Sub End Sub
Sub O2_AutoFitColumnWidth() Private Sub Do_Fit()
Call AutoFitColumnWidth(3, 15) Call AutoFitColumnWidth(3, 15)
End Sub 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 Desc: Z1 master data management (222)
' Module Methods: ' Module Methods:
' - Z1_Import ' - Import
' - Z1_Export ' - Export
' - Z1_SortDataRowsByC ' - SortData
' - Z1_ToggleAutoFilter ' - ToggleAutoFilter
' ============================================================ ' ============================================================
' ====== (222) ======= ' ====== (222) =======
@@ -15,11 +15,11 @@ Const END_COL As Long = 9
Const ERROR_COL As Long = 2 Const ERROR_COL As Long = 2
' ====== Function ====== ' ====== Function ======
Sub Z1_Import() Private Sub Import()
Call Generic_Master_Import(Me, 7) Call Generic_Master_Import(Me, 7)
End Sub End Sub
Sub Z1_Export() Private Sub Export()
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL) Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
If lastDataRow < 7 Then If lastDataRow < 7 Then
@@ -43,7 +43,7 @@ Sub Z1_Export()
Call Generic_Master_Export(Me, 7, lastDataRow) Call Generic_Master_Export(Me, 7, lastDataRow)
End Sub End Sub
Sub Validate(ByVal rowNum As Long) Private Sub validate(ByVal rowNum As Long)
Set ws = Me Set ws = Me
Dim cValue As String: cValue = Trim(ws.Cells(rowNum, 3).Value) 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 ws.Cells(rowNum, 2).ClearContents
End Sub End Sub
Sub Z1_validateButton() Private Sub validateButton()
Dim lastDataRow As Long, r As Long, errorCount As Long Dim lastDataRow As Long, r As Long, errorCount As Long
lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL) lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
@@ -168,14 +168,14 @@ Sub Z1_validateButton()
MsgBox "Validation complete. Errors: " & errorCount, vbInformation MsgBox "Validation complete. Errors: " & errorCount, vbInformation
End Sub End Sub
Sub Z1_SortDataRowsByC() Private Sub Do_Sort()
Call SortDataRows(3) Call SortDataRows(3)
End Sub End Sub
Sub Z1_ToggleAutoFilter() Private Sub Do_Filter()
Call ToggleAutoFilter(2, END_COL) Call ToggleAutoFilter(2, END_COL)
End Sub End Sub
Sub Z1_AutoFitColumnWidth() Private Sub Do_Fit()
Call AutoFitColumnWidth(2, END_COL) Call AutoFitColumnWidth(2, END_COL)
End Sub 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 Desc: Z2 master data management (223)
' Module Methods: ' Module Methods:
' - Z2_Import ' - Import
' - Z2_Export ' - Export
' - Z2_SortDataRowsByC ' - SortData
' - Z2_ToggleAutoFilter ' - ToggleAutoFilter
' ============================================================ ' ============================================================
' ====== (223) ======= ' ====== (223) =======
@@ -15,11 +15,11 @@ Const END_COL As Long = 7
Const ERROR_COL As Long = 2 Const ERROR_COL As Long = 2
' ====== Function ====== ' ====== Function ======
Sub Z2_Import() Private Sub Import()
Call Generic_Master_Import(Me, 5) Call Generic_Master_Import(Me, 5)
End Sub End Sub
Sub Z2_Export() Private Sub Export()
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL) Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
If lastDataRow < 7 Then If lastDataRow < 7 Then
@@ -43,7 +43,7 @@ Sub Z2_Export()
Call Generic_Master_Export(Me, 5, lastDataRow) Call Generic_Master_Export(Me, 5, lastDataRow)
End Sub End Sub
Sub Validate(ByVal rowNum As Long) Private Sub validate(ByVal rowNum As Long)
Set ws = Me Set ws = Me
Dim cValue As String: cValue = Trim(ws.Cells(rowNum, 3).Value) 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 ws.Cells(rowNum, 2).ClearContents
End Sub End Sub
Sub Z2_validateButton() Private Sub validateButton()
Dim lastDataRow As Long, r As Long, errorCount As Long Dim lastDataRow As Long, r As Long, errorCount As Long
lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL) lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
@@ -152,14 +152,14 @@ Sub Z2_validateButton()
MsgBox "Validation complete. Errors: " & errorCount, vbInformation MsgBox "Validation complete. Errors: " & errorCount, vbInformation
End Sub End Sub
Sub Z2_SortDataRowsByC() Private Sub Do_Sort()
Call SortDataRows(3) Call SortDataRows(3)
End Sub End Sub
Sub Z2_ToggleAutoFilter() Private Sub Do_Filter()
Call ToggleAutoFilter(2, END_COL) Call ToggleAutoFilter(2, END_COL)
End Sub End Sub
Sub Z2_AutoFitColumnWidth() Private Sub Do_Fit()
Call AutoFitColumnWidth(2, END_COL) Call AutoFitColumnWidth(2, END_COL)
End Sub 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 Const ERROR_COL As Long = 2
' ====== Function ====== ' ====== Function ======
Sub Z3_Import() Private Sub Import()
Call Generic_Master_Import(Me, 6) Call Generic_Master_Import(Me, 6)
End Sub End Sub
Sub Z3_Export() Private Sub Export()
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL) Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
If lastDataRow < 7 Then If lastDataRow < 7 Then
@@ -43,7 +43,7 @@ Sub Z3_Export()
Call Generic_Master_Export(Me, 6, lastDataRow) Call Generic_Master_Export(Me, 6, lastDataRow)
End Sub End Sub
Sub Validate(ByVal rowNum As Long) Private Sub validate(ByVal rowNum As Long)
Set ws = Me Set ws = Me
Dim cValue As String: cValue = Trim(ws.Cells(rowNum, 3).Value) 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 ws.Cells(rowNum, 2).ClearContents
End Sub End Sub
Sub Z3_validateButton() Private Sub validateButton()
Dim lastDataRow As Long, r As Long, errorCount As Long Dim lastDataRow As Long, r As Long, errorCount As Long
lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL) lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
@@ -160,14 +160,14 @@ Sub Z3_validateButton()
MsgBox "Validation complete. Errors: " & errorCount, vbInformation MsgBox "Validation complete. Errors: " & errorCount, vbInformation
End Sub End Sub
Sub Z3_SortDataRowsByC() Private Sub Do_Sort()
Call SortDataRows(3) Call SortDataRows(3)
End Sub End Sub
Sub Z3_ToggleAutoFilter() Private Sub Do_Filter()
Call ToggleAutoFilter(2, END_COL) Call ToggleAutoFilter(2, END_COL)
End Sub End Sub
Sub Z3_AutoFitColumnWidth() Private Sub Do_Fit()
Call AutoFitColumnWidth(2, END_COL) Call AutoFitColumnWidth(2, END_COL)
End Sub 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 Const ERROR_COL As Long = 2
' ====== Function ====== ' ====== Function ======
Sub Z4_Import() Private Sub Import()
Call Generic_Master_Import(Me, 7) Call Generic_Master_Import(Me, 7)
End Sub End Sub
Sub Z4_Export() Private Sub Export()
Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL) Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
If lastDataRow < 7 Then If lastDataRow < 7 Then
@@ -43,7 +43,7 @@ Sub Z4_Export()
Call Generic_Master_Export(Me, 7, lastDataRow) Call Generic_Master_Export(Me, 7, lastDataRow)
End Sub End Sub
Sub Validate(ByVal rowNum As Long) Private Sub validate(ByVal rowNum As Long)
Set ws = Me Set ws = Me
Dim cValue As String: cValue = Trim(ws.Cells(rowNum, 3).Value) 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 ws.Cells(rowNum, 2).ClearContents
End Sub End Sub
Sub Z4_validateButton() Private Sub validateButton()
Dim lastDataRow As Long, r As Long, errorCount As Long Dim lastDataRow As Long, r As Long, errorCount As Long
lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL) lastDataRow = GetLastDataRowInRange(Me, START_COL, END_COL)
@@ -160,14 +160,14 @@ Sub Z4_validateButton()
MsgBox "Validation complete. Errors: " & errorCount, vbInformation MsgBox "Validation complete. Errors: " & errorCount, vbInformation
End Sub End Sub
Sub Z4_SortDataRowsByC() Private Sub Do_Sort()
Call SortDataRows(3) Call SortDataRows(3)
End Sub End Sub
Sub Z4_ToggleAutoFilter() Private Sub Do_Filter()
Call ToggleAutoFilter(2, END_COL) Call ToggleAutoFilter(2, END_COL)
End Sub End Sub
Sub Z4_AutoFitColumnWidth() Private Sub Do_Fit()
Call AutoFitColumnWidth(2, END_COL) Call AutoFitColumnWidth(2, END_COL)
End Sub End Sub

BIN
test.xlsm Normal file
View File

Binary file not shown.

BIN
test.xlsx Normal file
View File

Binary file not shown.

BIN
通勤手当テンプレート_案.xlsm
View File

Binary file not shown.

BIN
通勤手当テンプレート_案.xlsx
View File

Binary file not shown.