266 lines
7.6 KiB
VB.net
266 lines
7.6 KiB
VB.net
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
|
|
|