203 lines
6.3 KiB
QBasic
203 lines
6.3 KiB
QBasic
' ============================================================
|
||
' Common Functions
|
||
' ============================================================
|
||
|
||
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
|
||
|
||
Sub ClearDataRows(ByVal ws As Worksheet, ByVal startRow As Long, ByVal columnNum As Long)
|
||
Dim lastRow As Long
|
||
lastRow = ws.Cells(ws.Rows.Count, columnNum).End(xlUp).Row
|
||
|
||
If lastRow >= startRow Then
|
||
ws.Range(ws.Cells(startRow, 1), ws.Cells(lastRow, 20)).ClearContents
|
||
End If
|
||
End Sub
|
||
|
||
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(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
|
||
Else
|
||
If filterRow >= 1 Then
|
||
ws.Rows(filterRow).AutoFilter
|
||
End If
|
||
End If
|
||
End Sub
|
||
|
||
Sub AutoFitColumnWidth(Optional ByVal fitColumnStart As Long = 2, Optional ByVal fitColumnEnd As Long = 9)
|
||
Dim ws As Worksheet
|
||
Set ws = ActiveSheet
|
||
|
||
If fitColumnStart <= fitColumnEnd Then
|
||
ws.Range(ws.Columns(fitColumnStart), ws.Columns(fitColumnEnd)).AutoFit
|
||
End If
|
||
End Sub
|