加入 CodeStore VBA 模組
This commit is contained in:
zhi committed
1 parent
9c5364f88e
commit
0e638bdd15
22 files changed
+4510
No files matched your search
@@ -0,0 +1,265 @@
|
||||
Attribute VB_Name = "工作表11"
|
||||
Private Const ROW_RESIZE_COUNT As Long = 1000
|
||||
Private Const OUTPUT_COL_START As Long = 3
|
||||
Private Const OUTPUT_COL_END As Long = 25
|
||||
|
||||
Private Enum OutputMode
|
||||
OutputModePerson = 1
|
||||
OutputModeBS = 2
|
||||
OutputModeWS = 3
|
||||
OutputModeLS = 4
|
||||
OutputModeWP = 5
|
||||
End Enum
|
||||
|
||||
' 目前模組內未使用，保留供未來擴充
|
||||
Private Enum ValueMode
|
||||
ValueModeCount = 1
|
||||
ValueModeSum = 2
|
||||
End Enum
|
||||
|
||||
' 輸出設定結構：集中管理各模式對應的欄位與索引
|
||||
Private Type OutputConfig
|
||||
ClearRows As Variant ' 要清除內容的列號陣列
|
||||
ClassRowMale As Long ' 男生標籤列
|
||||
DataRowMale As Long ' 男生資料列
|
||||
ClassRowFemale As Long ' 女生標籤列
|
||||
DataRowFemale As Long ' 女生資料列
|
||||
GenderIndex As Long ' 分解 key 後，性別所在索引 (0-based)
|
||||
LabelIndex As Long ' 分解 key 後，標籤所在索引 (0-based)
|
||||
SourceLabelCol As Long ' 來源工作表中的標籤欄位
|
||||
SourceGenderCol As Long ' 來源工作表中的性別欄位
|
||||
End Type
|
||||
|
||||
Private Sub Worksheet_Activate()
|
||||
Me.Cells(1, 1).value = "Update " & Date
|
||||
|
||||
Dim startTime As Double
|
||||
startTime = Timer
|
||||
|
||||
Application.Calculation = xlManual
|
||||
Call XLS_init
|
||||
|
||||
Call CalcClassCounts(OutputModePerson)
|
||||
' Call CalcClassCounts(OutputModeBS, 1)
|
||||
' Call CalcClassCounts(OutputModeWS, 2)
|
||||
' Call CalcClassCounts(OutputModeLS, 3)
|
||||
' Call CalcClassCounts(OutputModeWP, 4)
|
||||
|
||||
Application.Calculation = xlAutomatic
|
||||
|
||||
Me.Cells(6, 1).value = "執行時間：" & Format(Timer - startTime, "0.00") & " 秒"
|
||||
End Sub
|
||||
|
||||
Public Sub CalcClassCounts(mode As Variant, Optional strField As Variant)
|
||||
' strField 保留給未來小計欄位擴充使用
|
||||
Dim dictSubtotal As Object
|
||||
Set dictSubtotal = ProcessCustomerData(mode, strField)
|
||||
WriteOutputCommon dictSubtotal, mode
|
||||
End Sub
|
||||
|
||||
Private Sub WriteOutputCommon(ByVal dataDict As Object, ByVal mode As OutputMode)
|
||||
Dim dataKey As Variant
|
||||
Dim dataValue As Variant
|
||||
Dim arrWords As Variant
|
||||
Dim cfg As OutputConfig
|
||||
Dim cellClass As Range
|
||||
Dim cellData As Range
|
||||
Dim classRow As Long
|
||||
Dim dataRow As Long
|
||||
Dim currentLabel As String
|
||||
Dim colIndex As Long
|
||||
Dim sortedKeys As Variant
|
||||
Dim i As Long
|
||||
|
||||
On Error GoTo WriteOutputError
|
||||
|
||||
If dataDict Is Nothing Or dataDict.count = 0 Then Exit Sub
|
||||
|
||||
cfg = GetOutputConfig(mode)
|
||||
ClearOutputRows cfg.ClearRows
|
||||
|
||||
colIndex = 2 ' 第一個標籤會變成 3，對應欄位 C
|
||||
currentLabel = vbNullString
|
||||
sortedKeys = SortKeys(dataDict.keys)
|
||||
|
||||
For i = LBound(sortedKeys) To UBound(sortedKeys)
|
||||
dataKey = sortedKeys(i)
|
||||
arrWords = Split(dataKey, "_")
|
||||
dataValue = dataDict(dataKey)
|
||||
|
||||
If UBound(arrWords) < 1 Then
|
||||
Debug.Print "警告: 數據格式錯誤: " & dataKey
|
||||
GoTo NextItem
|
||||
End If
|
||||
|
||||
' 標籤改變時換下一欄
|
||||
If CStr(arrWords(cfg.LabelIndex)) <> currentLabel Then
|
||||
colIndex = colIndex + 1
|
||||
currentLabel = CStr(arrWords(cfg.LabelIndex))
|
||||
End If
|
||||
|
||||
If arrWords(cfg.GenderIndex) = "女" Then
|
||||
classRow = cfg.ClassRowFemale
|
||||
dataRow = cfg.DataRowFemale
|
||||
Else
|
||||
classRow = cfg.ClassRowMale
|
||||
dataRow = cfg.DataRowMale
|
||||
End If
|
||||
|
||||
Set cellClass = Me.Cells(classRow, colIndex)
|
||||
Set cellData = Me.Cells(dataRow, colIndex)
|
||||
cellClass.value = arrWords(cfg.LabelIndex)
|
||||
cellData.value = dataValue
|
||||
|
||||
NextItem:
|
||||
Next i
|
||||
|
||||
Exit Sub
|
||||
|
||||
WriteOutputError:
|
||||
MsgBox "寫入輸出時發生錯誤: " & Err.Description, vbExclamation, "寫入錯誤"
|
||||
Exit Sub
|
||||
End Sub
|
||||
|
||||
Private Sub ClearOutputRows(ByVal rows As Variant)
|
||||
Dim idx As Long
|
||||
|
||||
For idx = LBound(rows) To UBound(rows)
|
||||
Me.Range(Me.Cells(rows(idx), OUTPUT_COL_START), Me.Cells(rows(idx), OUTPUT_COL_END)).ClearContents
|
||||
Next idx
|
||||
End Sub
|
||||
|
||||
Private Function GetOutputConfig(ByVal mode As OutputMode) As OutputConfig
|
||||
Dim cfg As OutputConfig
|
||||
|
||||
Select Case mode
|
||||
Case OutputModePerson
|
||||
cfg.ClearRows = Array(2, 3, 4)
|
||||
cfg.ClassRowMale = 2
|
||||
cfg.DataRowMale = 3
|
||||
cfg.ClassRowFemale = 2
|
||||
cfg.DataRowFemale = 4
|
||||
cfg.GenderIndex = 1
|
||||
cfg.LabelIndex = 0
|
||||
cfg.SourceLabelCol = 4
|
||||
cfg.SourceGenderCol = 7
|
||||
Case OutputModeBS
|
||||
cfg.ClearRows = Array(9, 10, 11)
|
||||
cfg.ClassRowMale = 9
|
||||
cfg.DataRowMale = 10
|
||||
cfg.ClassRowFemale = 9
|
||||
cfg.DataRowFemale = 11
|
||||
cfg.GenderIndex = 1
|
||||
cfg.LabelIndex = 0
|
||||
cfg.SourceLabelCol = 12
|
||||
cfg.SourceGenderCol = 5
|
||||
Case OutputModeWS
|
||||
cfg.ClearRows = Array(16, 17, 18)
|
||||
cfg.ClassRowMale = 16
|
||||
cfg.DataRowMale = 17
|
||||
cfg.ClassRowFemale = 16
|
||||
cfg.DataRowFemale = 18
|
||||
cfg.GenderIndex = 1
|
||||
cfg.LabelIndex = 0
|
||||
cfg.SourceLabelCol = 13
|
||||
cfg.SourceGenderCol = 5
|
||||
Case OutputModeLS
|
||||
cfg.ClearRows = Array(33, 36, 38, 41)
|
||||
cfg.ClassRowMale = 33
|
||||
cfg.DataRowMale = 36
|
||||
cfg.ClassRowFemale = 38
|
||||
cfg.DataRowFemale = 41
|
||||
cfg.GenderIndex = 0
|
||||
cfg.LabelIndex = 1
|
||||
cfg.SourceLabelCol = 0 ' TODO: 請填入實際欄位
|
||||
cfg.SourceGenderCol = 0 ' TODO: 請填入實際欄位
|
||||
Case OutputModeWP
|
||||
cfg.ClearRows = Array(45, 48, 50, 53)
|
||||
cfg.ClassRowMale = 45
|
||||
cfg.DataRowMale = 48
|
||||
cfg.ClassRowFemale = 50
|
||||
cfg.DataRowFemale = 53
|
||||
cfg.GenderIndex = 0
|
||||
cfg.LabelIndex = 1
|
||||
cfg.SourceLabelCol = 0 ' TODO: 請填入實際欄位
|
||||
cfg.SourceGenderCol = 0 ' TODO: 請填入實際欄位
|
||||
Case Else
|
||||
Err.Raise vbObjectError + 1, "GetOutputConfig", "未知的輸出模式"
|
||||
End Select
|
||||
|
||||
GetOutputConfig = cfg
|
||||
End Function
|
||||
|
||||
Private Function ProcessCustomerData(mode As Variant, Optional strField As Variant) As Object
|
||||
Dim dict As Object
|
||||
Dim sourceRange As Variant
|
||||
Dim wsSource As Worksheet
|
||||
Dim i As Long
|
||||
Dim cfg As OutputConfig
|
||||
Dim labelValue As Variant
|
||||
Dim genderValue As Variant
|
||||
Dim dictKey As String
|
||||
|
||||
Set dict = CreateObject("Scripting.Dictionary")
|
||||
Set wsSource = ActiveWorkbook.Worksheets("帳務")
|
||||
sourceRange = wsSource.Range("Cu帳務").Resize(ROW_RESIZE_COUNT)
|
||||
cfg = GetOutputConfig(mode)
|
||||
|
||||
For i = 1 To UBound(sourceRange, 1)
|
||||
If Not IsEmpty(sourceRange(i, 1)) Then
|
||||
labelValue = sourceRange(i, cfg.SourceLabelCol)
|
||||
genderValue = sourceRange(i, cfg.SourceGenderCol)
|
||||
|
||||
If cfg.LabelIndex = 0 Then
|
||||
dictKey = labelValue & "_" & genderValue
|
||||
Else
|
||||
dictKey = genderValue & "_" & labelValue
|
||||
End If
|
||||
|
||||
SetDictionaryValue dict, dictKey, 1
|
||||
End If
|
||||
Next i
|
||||
|
||||
Set ProcessCustomerData = dict
|
||||
End Function
|
||||
|
||||
Private Sub SetDictionaryValue(ByRef dict As Object, ByVal key As Variant, ByVal value As Variant)
|
||||
If dict.Exists(key) Then
|
||||
dict(key) = dict(key) + value
|
||||
Else
|
||||
dict.Add key, value
|
||||
End If
|
||||
End Sub
|
||||
|
||||
' 以氣泡排序法回傳排序後的 key 陣列，避免依賴外部 stdArray 函式庫
|
||||
Private Function SortKeys(keys As Variant) As Variant
|
||||
Dim arr() As Variant
|
||||
Dim i As Long
|
||||
Dim j As Long
|
||||
Dim temp As Variant
|
||||
Dim n As Long
|
||||
|
||||
n = UBound(keys) - LBound(keys) + 1
|
||||
If n <= 1 Then
|
||||
SortKeys = keys
|
||||
Exit Function
|
||||
End If
|
||||
|
||||
ReDim arr(LBound(keys) To UBound(keys))
|
||||
For i = LBound(keys) To UBound(keys)
|
||||
arr(i) = keys(i)
|
||||
Next i
|
||||
|
||||
For i = LBound(arr) To UBound(arr) - 1
|
||||
For j = i + 1 To UBound(arr)
|
||||
If arr(i) > arr(j) Then
|
||||
temp = arr(i)
|
||||
arr(i) = arr(j)
|
||||
arr(j) = temp
|
||||
End If
|
||||
Next j
|
||||
Next i
|
||||
|
||||
SortKeys = arr
|
||||
End Function
|
||||
|
||||
Reference in new issue
Block a user