refactor

2026-04-23 21:02:16 +09:00
parent c6d53813e3
commit ae56faf697
23 changed files with 424 additions and 34 deletions
--- a/src/sh/tuk/module/Common_Functions.bas
+++ b/src/sh/tuk/module/Common_Functions.bas
@@ -0,0 +1,486 @@
+Attribute VB_Name = "Common_Functions"
+Option Explicit
+' ============================================================
+' Module Name: Module_Common
+' Module Desc: Common utility functions for all modules
+' Module Methods:
+'   - GetLastDataRowInRange
+'   - ClearDataRows
+'   - ClearDataRow
+' ============================================================
+
+' Common Functions
+
+' Get CSV header from specified row and columns
+Function GetCSVHeader(ByVal ws As Worksheet) As Variant
+    On Error GoTo ErrorHandler
+    '
+    Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
+    Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
+
+    Dim colLetters As Variant: colLetters = sheetConf("HeaderColumns")
+    Dim headerRow As Long: headerRow = sheetConf("HeaderRow")
+
+    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
+        Dim colIndex As Long
+        colIndex = Columns(colLetters(i)).Column
+
+        cellValue = Trim(ws.Cells(headerRow, colIndex).Value)
+        cellValue = Replace(cellValue, vbLf, "")
+        cellValue = Replace(cellValue, vbCr, "")
+        cellValue = Replace(cellValue, vbCrLf, "")
+        headerArr(1, i + 1) = cellValue
+    Next i
+    
+    GetCSVHeader = headerArr
+    Exit Function
+
+ErrorHandler:
+    Err.Raise 1005, "GetCSVHeader", "Invalid column letter in HeaderColumns: '" & colLetters(i) & "'"
+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
+
+Function Contains(ByVal arr As Variant, ByVal value As String) As Boolean
+    Dim i As Long
+    For i = 0 To UBound(arr)
+        If arr(i) = value Then
+            Contains = True
+            Exit Function
+        End If
+    Next i
+
+    Contains = False
+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 cacheName As String) As Object
+    On Error GoTo ErrHandler
+
+    ' --- validate ---
+    If Trim(sheetName) = "" Then Err.Raise 0001, "LoadLookup", "Sheet name cannot be empty."
+
+    Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
+    If Not sheetConfDict.Exists(sheetName) Then
+        Err.Raise 1004, "LoadLookup", "Sheet not configured: " & sheetName
+    End If
+    
+    ' --- obtain worksheet ---
+    On Error Resume Next
+    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(sheetName)
+    If ws Is Nothing Then Err.Raise 0003, "LoadLookup", "Worksheet named '" & sheetName & "' not found."
+    On Error GoTo ErrHandler
+
+    Dim sheetConf As Object: Set sheetConf = sheetConfDict(cacheName)
+    Dim startRow As Long: startRow = sheetConf("StartRow")
+    Dim keyCol As Long: keyCol = sheetConf("KeyCol")
+    Dim valueCols As Variant: valueCols = sheetConf("ValueCols")
+
+    Dim lastRow As Long
+    If sheetName <> cacheName Then
+        lastRow = ws.Cells(ws.Rows.Count, keyCol).End(xlUp).Row
+    Else
+        lastRow = GetLastDataRowInRange(ws)
+    End If
+    
+    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
+    If lastRow < startRow Then 
+        Set LoadLookup = dict
+        Exit Function
+    End If
+
+    Dim nValCols As Long: nValCols = UBound(valueCols) - LBound(valueCols) + 1
+    If nValCols = 0 Then Err.Raise 0002, "LoadLookup", "Value columns parameter is invalid."
+
+    ' --- 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  ---
+    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
+    Exit Function
+
+ErrHandler:
+    Err.Raise Err.Number, Err.Source, Err.Description
+End Function
+
+' obtain
+Function GetLastDataRowInRange(ws As Worksheet) As Long
+
+    Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
+
+    If sheetConfDict.Exists(ws.CodeName) Then
+        Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
+
+        Dim startCol As Long, endCol As Long, startRow As Long
+        On Error GoTo InvalidColumn
+        startCol = ws.Range(sheetConf("StartCol") & "1").Column
+        endCol = ws.Range(sheetConf("EndCol") & "1").Column
+        startRow = sheetConf("StartRow")
+        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
+
+Sub ClearDataRows(ByVal ws As Worksheet)
+    ' 
+    Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
+    ' 
+    If Not sheetConfDict.Exists(ws.CodeName) Then
+        Err.Raise 1004, "ClearDataRows", "Sheet not configured: " & ws.CodeName
+    End If
+
+    Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
+
+    Dim startRow As Long: startRow = sheetConf("StartRow")
+    Dim startCol As String: startCol = sheetConf("StartCol")
+    Dim endCol As String: endCol = sheetConf("EndCol")
+    Dim errorCol As String: errorCol = sheetConf("ErrorCol")
+    '
+    Dim lastDataRow As Long: lastDataRow = GetLastDataRowInRange(ws)
+    
+    '
+    If lastDataRow >= startRow Then
+        Dim clearRange As Range
+        Set clearRange = ws.Range(ws.Cells(startRow, ws.Range(startCol & "1").Column), ws.Cells(lastDataRow, ws.Range(endCol & "1").Column))
+        clearRange.ClearContents
+        clearRange.Interior.Color = vbWhite
+
+        If errorCol <> "" Then
+          Dim clearErrorRange As Range
+          Set clearErrorRange = ws.Range(ws.Cells(startRow, ws.Range(errorCol & "1").Column), ws.Cells(lastDataRow, ws.Range(errorCol & "1").Column))
+          clearErrorRange.ClearContents
+          clearErrorRange.Interior.Color = vbWhite
+        End If
+    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
+
+Function CheckHeaderEdit(ByVal ws As Worksheet, ByVal Target As Range) As Boolean
+    Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig()
+    Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName)
+    Dim headerRow As Long: headerRow = sheetConf("HeaderRow")
+
+    ' Check header row (headerRow) cannot be edited
+    If Target.Row = headerRow Then
+        Application.EnableEvents = False
+        MsgBox "Header row can not be edit", vbExclamation
+        Application.Undo
+        Application.EnableEvents = True
+
+        CheckHeaderEdit = True
+        Exit Function
+    End If
+
+    CheckHeaderEdit = False
+End Function
+
+Function GetErrorMsg(ByVal errorCode As String, Optional ByVal param0 As String = "", Optional ByVal param1 As String = "") As String
+    Dim errorList As Object: Set errorList = GetCache("errorList")
+    Dim errorMessage As String
+    If errorList.Exists(errorCode) Then
+        errorMessage = Replace(errorList(errorCode)(0), "{0}", param0)
+        errorMessage = Replace(errorMessage, "{1}", param1)
+        errorMessage = MakeSelect(errorCode, errorMessage)
+    End If
+    GetErrorMsg = errorMessage
+End Function
+
+Function ColLetter(colNum As Long) As String
+    ColLetter = Split(Cells(1, colNum).Address, "$")(1)
+End Function
+
+Function CheckRequired(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal errorCol As String) As Boolean
+    Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
+    If checkValue = "" Then
+        Dim letter As String: letter = ColLetter(colNum)
+        ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E002", letter & rowNum)
+        ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
+        CheckRequired = False
+        Exit Function
+    End If
+    CheckRequired = True
+End Function
+
+Function CheckChar(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal charLength As Long, ByVal errorCol As String)
+    Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
+    If Len(checkValue) <> charLength Then
+        Dim letter As String: letter = ColLetter(colNum)
+        ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E006", letter & rowNum, charLength)
+        ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
+        CheckChar = False
+        Exit Function
+    End If
+    CheckChar = True
+End Function
+
+Function CheckAlphanumeric(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal charLength As Long, ByVal errorCol As String)
+    Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
+    Dim letter As String: letter = ColLetter(colNum)
+    Dim i As Long
+    Dim ch As String
+    For i = 1 To charLength
+        ch = Mid(checkValue, i, 1)
+        If Not ((ch >= "0" And ch <= "9") Or (ch >= "A" And ch <= "Z") Or (ch >= "a" And ch <= "z")) Then
+            ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E005", letter & rowNum)
+            ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
+            CheckAlphanumeric = False
+            Exit Function
+        End If
+    Next i
+
+    CheckAlphanumeric = True
+End Function
+
+Function CheckVarcharOver(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal varcharLength As Long, ByVal errorCol As String)
+    Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
+    If Len(checkValue) > varcharLength Then
+        Dim letter As String: letter = ColLetter(colNum)
+        ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E007", letter & rowNum)
+        ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
+        CheckVarcharOver = False
+        Exit Function
+    End If
+    CheckVarcharOver = True
+End Function
+
+Function CheckNumberOver(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal numberLength As Long, ByVal errorCol As String)
+    Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
+    If Len(checkValue) > numberLength Then
+        Dim letter As String: letter = ColLetter(colNum)
+        ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E014", letter & rowNum, numberLength)
+        ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
+        CheckNumberOver = False
+        Exit Function
+    End If
+    CheckNumberOver = True
+End Function
+
+Function Check01(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal errorCol As String)
+    Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
+    Dim letter As String: letter = ColLetter(colNum)
+    If checkValue <> "" Then
+        If Len(checkValue) <> 1 Then
+            ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E001", letter & rowNum)
+            ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
+            Check01 = False
+            Exit Function
+        End If
+        If checkValue <> "0" And checkValue <> "1" Then
+            ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E008", letter & rowNum)
+            ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
+            Check01 = False
+            Exit Function
+        End If
+    End If
+    Check01 = True
+End Function
+
+Function Check12(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal errorCol As String)
+    Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
+    Dim letter As String: letter = ColLetter(colNum)
+    If checkValue <> "" Then
+        If Len(checkValue) <> 1 Then
+            ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E001", letter & rowNum)
+            ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
+            Check12 = False
+            Exit Function
+        End If
+        If checkValue <> "1" And checkValue <> "2" Then
+            ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E009", letter & rowNum)
+            ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
+            Check12 = False
+            Exit Function
+        End If
+    End If
+    Check12 = True
+End Function
+
+Function CheckDuplicate(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal errorCol As String) As Boolean
+    Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
+    Dim letter As String: letter = ColLetter(colNum)
+    Dim i As Long
+    
+    For i = 7 To rowNum - 1
+        If Trim(ws.Cells(i, colNum).Value) = checkValue Then
+            ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E010", letter & rowNum, checkValue)
+            ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
+            CheckDuplicate = False
+            Exit Function
+        End If
+    Next i
+    
+    CheckDuplicate = True
+End Function
+
+Function CheckNumber(ByVal ws As Worksheet, ByVal rowNum As Long, ByVal colNum As Long, ByVal errorCol As String) As Boolean
+    Dim checkValue As String: checkValue = Trim(ws.Cells(rowNum, colNum).Value)
+    Dim letter As String: letter = ColLetter(colNum)
+    
+    If checkValue = "" Then
+        CheckNumber = True
+        Exit Function
+    End If
+
+    If Not IsNumeric(checkValue) Then
+        ws.Cells(rowNum, errorCol).Value = GetErrorMsg("E011", letter & rowNum)
+        ws.Cells(rowNum, colNum).Interior.Color = RGB(255, 0, 0)
+        CheckNumber = False
+        Exit Function
+    End If
+    
+    CheckNumber = True
+End Function