487 lines
17 KiB
QBasic
487 lines
17 KiB
QBasic
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
|