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 ERR_CONFIG_INVALID, "GetCSVHeader", "Invalid column letter in HeaderColumns: '" & colLetters(i) & "'" End Function ' Clean CSV field: add quote prefix for formula-like values 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 ' Get last data row in specified column Function GetLastDataRow(ByVal ws As Worksheet, ByVal columnNum As Long) As Long GetLastDataRow = ws.Cells(ws.Rows.Count, columnNum).End(xlUp).Row End Function ' Check if array contains value 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 ERR_CONFIG_EMPTY_PARAM, "LoadLookup", "Sheet name cannot be empty." Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig() If Not sheetConfDict.Exists(sheetName) Then Err.Raise ERR_CONFIG_NOT_FOUND, "LoadLookup", "Sheet not configured: " & sheetName End If ' --- obtain worksheet --- Dim ws As Worksheet On Error Resume Next Set ws = ThisWorkbook.Worksheets(sheetName) On Error GoTo ErrHandler If ws Is Nothing Then Err.Raise ERR_SHEET_MISSING, "LoadLookup", "Worksheet '" & sheetName & "' not found." End If 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 ERR_CONFIG_EMPTY_PARAM, "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 Err.Raise ERR_CONFIG_INVALID, "LoadLookup", "Value column is not numeric at index " & i End If Dim colNum As Long: colNum = CLng(valueCols(i)) If colNum < 1 Then Err.Raise ERR_CONFIG_INVALID, "LoadLookup", "Value column must be >= 1, got " & colNum End If 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 ' Get last data row in specified column 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 ERR_CONFIG_NOT_FOUND, "GetLastDataRowInRange", "Sheet not configured: " & ws.CodeName End If Exit Function InvalidColumn: Err.Raise ERR_CONFIG_INVALID, "GetLastDataRowInRange", "Invalid column letter for sheet: " & ws.CodeName End Function 'Clear single row data and format Sub ClearDataRow(ByVal ws As Worksheet, ByVal rowNum As Long) Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig() If Not sheetConfDict.Exists(ws.CodeName) Then Err.Raise ERR_CONFIG_NOT_FOUND, "ClearDataRow", "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 clearRange As Range: Set clearRange = ws.Range(ws.Cells(rowNum, startCol), ws.Cells(rowNum, endCol)) clearRange.ClearContents clearRange.Interior.Color = vbWhite clearRange.Validation.Delete Dim errorRange As Range: Set errorRange = ws.Range(ws.Cells(rowNum, errorCol), ws.Cells(rowNum, errorCol)) errorRange.ClearContents errorRange.Interior.Color = vbWhite errorRange.Validation.Delete End Sub 'Clear all data rows from startRow to lastDataRow Sub ClearDataRows(ByVal ws As Worksheet) ' Clear data and format from startRow to lastDataRow Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig() ' If Not sheetConfDict.Exists(ws.CodeName) Then Err.Raise ERR_CONFIG_NOT_FOUND, "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") Application.EnableEvents = False 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 ' Clear formats below lastDataRow (including dropdowns) Application.EnableEvents = True Call ClearFormatsBelowLastDataRow(ws) End Sub 'Clear formats below lastDataRow Sub ClearFormatsBelowLastDataRow(ws As Worksheet) On Error GoTo ErrorHandler Dim lastRow As Long: lastRow = GetLastDataRowInRange(ws) Dim sheetConfDict As Object: Set sheetConfDict = GetSheetConfig() Dim sheetConf As Object: Set sheetConf = sheetConfDict(ws.CodeName) Dim startCol As Long, endCol As Long startCol = ws.Range(sheetConf("ErrorCol") & "1").Column endCol = ws.Range(sheetConf("EndCol") & "1").Column If lastRow >= ws.Rows.Count Then Exit Sub Dim clearRange As Range Set clearRange = ws.Range( _ ws.Cells(lastRow + 1, startCol), _ ws.Cells(ws.Rows.Count, endCol) _ ) Application.EnableEvents = False clearRange.ClearContents clearRange.Interior.Color = vbWhite clearRange.Validation.Delete Application.EnableEvents = True ErrorHandler: Application.EnableEvents = True End Sub ' Check if text starts with prefix Function StartsWith(text As String, prefix As String) As Boolean If Len(text) < Len(prefix) Then StartsWith = False Else StartsWith = (Left(text, Len(prefix)) = prefix) End If End Function ' Make select format: code:value 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 'Check header edit protection 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 filterRow As Long: filterRow = sheetConf("FilterRow") ' Check rows 1 to filterRow cannot be edited Dim r As Long For r = Target.Row To Target.Row + Target.Rows.Count - 1 If r >= 1 And r <= filterRow Then Application.EnableEvents = False MsgBox "Cannot edit rows 1 to " & filterRow & ".", vbExclamation Application.Undo Application.EnableEvents = True CheckHeaderEdit = True Exit Function End If Next r ' filterRow color is not equals to filterRow + 1 If Target.Row = filterRow + 1 Then Dim firstCell As Range: Set firstCell = Target.Cells(1, 1) Dim colIndex As Long: colIndex = firstCell.Column Dim refCell As Range: Set refCell = ws.Cells(filterRow, colIndex) If firstCell.Interior.Color = refCell.Interior.Color Then Application.EnableEvents = False MsgBox "Cannot autoFill from filterRow.", vbExclamation Application.Undo Application.EnableEvents = True CheckHeaderEdit = True Exit Function End If End If CheckHeaderEdit = False End Function 'Get error message by code 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 'Convert column number to letter Function ColLetter(colNum As Long) As String ColLetter = Split(Cells(1, colNum).Address, "$")(1) End Function 'Check required field is not empty 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 'Check character length 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 'Check alphanumeric characters 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 'Check varchar length overflow 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 'Check number length overflow 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 'Check value is 0 or 1 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 'Check value is 1 or 2 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 'Check duplicate value in column 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 'Check numeric value 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