next version
This commit is contained in:
updsv7
303
src/module/Common_Functions.bas
Normal file
303
src/module/Common_Functions.bas
Normal file
@@ -0,0 +1,303 @@
|
||||
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
|
||||
Reference in New Issue
Block a user