diff --git a/src/thisWorkbook/Tukin_C1_Action.md b/documents/Tukin_C1_Action.md similarity index 100% rename from src/thisWorkbook/Tukin_C1_Action.md rename to documents/Tukin_C1_Action.md diff --git a/src/thisWorkbook/Tukin_C1_Mapping.md b/documents/Tukin_C1_Mapping.md similarity index 100% rename from src/thisWorkbook/Tukin_C1_Mapping.md rename to documents/Tukin_C1_Mapping.md diff --git a/src/thisWorkbook/Tukin_Cache_Mapping.md b/documents/Tukin_Cache_Mapping.md similarity index 100% rename from src/thisWorkbook/Tukin_Cache_Mapping.md rename to documents/Tukin_Cache_Mapping.md diff --git a/src/init_module/Import_modules.bas b/src/init_module/Import_modules.bas new file mode 100644 index 0000000..ecf6c45 --- /dev/null +++ b/src/init_module/Import_modules.bas @@ -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 \ No newline at end of file diff --git a/src/module/Test_Cache.bas b/src/init_module/Test_Cache.bas similarity index 99% rename from src/module/Test_Cache.bas rename to src/init_module/Test_Cache.bas index 9acf82e..d7bc594 100644 --- a/src/module/Test_Cache.bas +++ b/src/init_module/Test_Cache.bas @@ -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 diff --git a/src/module/Common_Button.bas b/src/module/Common_Button.bas new file mode 100644 index 0000000..32a5874 --- /dev/null +++ b/src/module/Common_Button.bas @@ -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 \ No newline at end of file diff --git a/src/module/Read_Common.bas b/src/module/Common_File_Utils.bas similarity index 58% rename from src/module/Read_Common.bas rename to src/module/Common_File_Utils.bas index f9a7e17..4386b13 100644 --- a/src/module/Read_Common.bas +++ b/src/module/Common_File_Utils.bas @@ -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 \ No newline at end of file diff --git a/src/module/Module_Common.bas b/src/module/Common_Functions.bas similarity index 76% rename from src/module/Module_Common.bas rename to src/module/Common_Functions.bas index dc87483..a6f9a7d 100644 --- a/src/module/Module_Common.bas +++ b/src/module/Common_Functions.bas @@ -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 diff --git a/src/module/Generic_Master_Common.bas b/src/module/Common_Generic_Master.bas similarity index 98% rename from src/module/Generic_Master_Common.bas rename to src/module/Common_Generic_Master.bas index e34b1e5..46bdc04 100644 --- a/src/module/Generic_Master_Common.bas +++ b/src/module/Common_Generic_Master.bas @@ -1,3 +1,5 @@ +Attribute VB_Name = "Common_Generic_Master" +Option Explicit ' ============================================================ ' Module Name: Generic_Master_Common ' Module Desc: Generic Master Import/Export functions diff --git a/src/module/Global_Cache.bas b/src/module/Common_Global_Cache.bas similarity index 91% rename from src/module/Global_Cache.bas rename to src/module/Common_Global_Cache.bas index 1e4d85c..328d0e2 100644 --- a/src/module/Global_Cache.bas +++ b/src/module/Common_Global_Cache.bas @@ -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 \ No newline at end of file diff --git a/src/module/Build_Select.bas b/src/module/Common_Selector.bas similarity index 98% rename from src/module/Build_Select.bas rename to src/module/Common_Selector.bas index 6243b12..7bf0aba 100644 --- a/src/module/Build_Select.bas +++ b/src/module/Common_Selector.bas @@ -1,3 +1,5 @@ +Attribute VB_Name = "Common_Selector" +Option Explicit ' ============================================================ ' Module Name: Build_Select ' Module Desc: Commuter allowance editing sheet (no CSV import) diff --git a/src/module/Validate_Common.bas b/src/module/Validate_Common.bas deleted file mode 100644 index a6b131e..0000000 --- a/src/module/Validate_Common.bas +++ /dev/null @@ -1,10 +0,0 @@ -'============================================================================= -'============================================================================= - -Option Explicit - -'----------------------------------------------------------------------------- -'----------------------------------------------------------------------------- -Public Function IsDateString(ByVal inputStr As String) As Boolean - -End Function \ No newline at end of file diff --git a/src/module/Write_Common.bas b/src/module/Write_Common.bas deleted file mode 100644 index 52ce8c7..0000000 --- a/src/module/Write_Common.bas +++ /dev/null @@ -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 \ No newline at end of file diff --git a/src/thisWorkbook/Tukin_C1.bas b/src/sheet/C1.cls similarity index 96% rename from src/thisWorkbook/Tukin_C1.bas rename to src/sheet/C1.cls index 0c9684b..96a933f 100644 --- a/src/thisWorkbook/Tukin_C1.bas +++ b/src/sheet/C1.cls @@ -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 diff --git a/src/thisWorkbook/Master_M1_Kukan.bas b/src/sheet/M1.cls similarity index 92% rename from src/thisWorkbook/Master_M1_Kukan.bas rename to src/sheet/M1.cls index bd14c7a..18d2d1c 100644 --- a/src/thisWorkbook/Master_M1_Kukan.bas +++ b/src/sheet/M1.cls @@ -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 \ No newline at end of file diff --git a/src/thisWorkbook/Master_M2_Kukan_detail.bas b/src/sheet/M2.cls similarity index 93% rename from src/thisWorkbook/Master_M2_Kukan_detail.bas rename to src/sheet/M2.cls index d0896c6..a88a5e4 100644 --- a/src/thisWorkbook/Master_M2_Kukan_detail.bas +++ b/src/sheet/M2.cls @@ -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 \ No newline at end of file diff --git a/src/thisWorkbook/Master_O1_address.bas b/src/sheet/O1.cls similarity index 86% rename from src/thisWorkbook/Master_O1_address.bas rename to src/sheet/O1.cls index c754d71..8129eca 100644 --- a/src/thisWorkbook/Master_O1_address.bas +++ b/src/sheet/O1.cls @@ -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 diff --git a/src/thisWorkbook/Master_O2_507.bas b/src/sheet/O2.cls similarity index 64% rename from src/thisWorkbook/Master_O2_507.bas rename to src/sheet/O2.cls index 8845210..5833022 100644 --- a/src/thisWorkbook/Master_O2_507.bas +++ b/src/sheet/O2.cls @@ -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 diff --git a/src/thisWorkbook/Master_Z1_222.bas b/src/sheet/Z1.cls similarity index 94% rename from src/thisWorkbook/Master_Z1_222.bas rename to src/sheet/Z1.cls index e0bc4ff..f867988 100644 --- a/src/thisWorkbook/Master_Z1_222.bas +++ b/src/sheet/Z1.cls @@ -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 \ No newline at end of file diff --git a/src/thisWorkbook/Master_Z2_223.bas b/src/sheet/Z2.cls similarity index 94% rename from src/thisWorkbook/Master_Z2_223.bas rename to src/sheet/Z2.cls index e9c8951..dbe220d 100644 --- a/src/thisWorkbook/Master_Z2_223.bas +++ b/src/sheet/Z2.cls @@ -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 \ No newline at end of file diff --git a/src/thisWorkbook/Master_Z3_224.bas b/src/sheet/Z3.cls similarity index 96% rename from src/thisWorkbook/Master_Z3_224.bas rename to src/sheet/Z3.cls index 74612b8..2b3cc31 100644 --- a/src/thisWorkbook/Master_Z3_224.bas +++ b/src/sheet/Z3.cls @@ -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 \ No newline at end of file diff --git a/src/thisWorkbook/Master_Z4_220.bas b/src/sheet/Z4.cls similarity index 96% rename from src/thisWorkbook/Master_Z4_220.bas rename to src/sheet/Z4.cls index 094f621..cc04163 100644 --- a/src/thisWorkbook/Master_Z4_220.bas +++ b/src/sheet/Z4.cls @@ -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 \ No newline at end of file diff --git a/test.xlsm b/test.xlsm new file mode 100644 index 0000000..ef73ca4 Binary files /dev/null and b/test.xlsm differ diff --git a/test.xlsx b/test.xlsx new file mode 100644 index 0000000..cd387d8 Binary files /dev/null and b/test.xlsx differ diff --git a/通勤手当テンプレート_案.xlsm b/通勤手当テンプレート_案.xlsm index 982647d..c0291d5 100644 Binary files a/通勤手当テンプレート_案.xlsm and b/通勤手当テンプレート_案.xlsm differ diff --git a/通勤手当テンプレート_案.xlsx b/通勤手当テンプレート_案.xlsx index d2526f7..f8868e0 100644 Binary files a/通勤手当テンプレート_案.xlsx and b/通勤手当テンプレート_案.xlsx differ