Attribute VB_Name = "工作表8"
'**************** 程式變數 ******************
Const PYEAR = 2024
Const PCOMPANY = 27
Const strXLSfile = "\index.xlsb"                 '資料來源
Const FieldAmount = 23                          '表中欄位數目
Const srtRange = "wordSort"                     '排序名稱
Const ITEMcount = 9                             '處理品項數目
Dim SELLITEM()

Private Sub Worksheet_Activate()
'********************************************
' === 使用品項，欄位，行數 ===
SELLITEM() = Array(Array("", 0, True) _
        , Array("校短", 9, True) _
        , Array("校長", 21, True) _
        , Array("校夏", 33, True) _
        , Array("校冬", 45, True) _
        , Array("校裙", 57, True) _
        , Array("背心", 69, True) _
        , Array("領帶", 81, False) _
        , Array("腰帶", 89, False) _
        , Array("書包", 97, False))
'********************************************
'====================================+
Dim p As Long                       '|
Dim diag As New ProgressDialogue    '|
'====================================+
    Call XLS_init
    Application.Calculation = xlManual          '設置手動重算
    
    Cells(1, 1).value = "統計" & Date
    Call statClass(2, 3)      '人數統計
'====================================================================================+
p = 0                                                                               '|
diag.Configure "更新資料時間", "Now wasting your time...", 0, ITEMcount             '|
diag.Show                                                                           '|
'====================================================================================+
    For i = 1 To ITEMcount
        Call QueryItem(SELLITEM(i)(0), SELLITEM(i)(1), SELLITEM(i)(2))
'================================================+
diag.SetValue p                                 '|
diag.SetStatus "Now wasting your time... " & p  '|
p = p + 1                                       '|
'================================================+
    Next i
'============+
diag.Hide   '|
'============+
    Application.Calculation = xlAutomatic       '設置自動重算
End Sub

Public Sub QueryItem(strItem As Variant, intRow As Variant, blnNosize As Variant)
' strItem   項目
' intRow    填表行位置
Dim rstEmployees As New ADODB.Recordset
Dim strSQLEmployees As String
Dim Cnxn As ADODB.Connection
Set Cnxn = Cnxnopen(XLSfile, "1")
If blnNosize = True Then
    strSQLEmployees = "SELECT [" & strItem & "尺碼],sum([" & strItem & "訂購]) as people" & _
                    " FROM [帳務$]A LEFT JOIN [引數$" & Replace(Sheets("引數").Range(srtRange).Address, "$", "") & _
                    "]B ON A.[" & strItem & "尺碼]=B.[排序]" & _
                    " where [性別]='男'" & _
                    " group by [" & strItem & "尺碼],B.[序號]" & _
                    " ORDER BY B.[序號];"
' Debug.Print strSQLEmployees
rstEmployees.Open strSQLEmployees, Cnxn, adOpenStatic, adLockOptimistic, adCmdText
    Call QueryItemEx1(rstEmployees, "男" & strItem, intRow)
rstEmployees.Close
    strSQLEmployees = "SELECT [" & strItem & "尺碼],sum([" & strItem & "訂購]) as people" & _
                    " FROM [帳務$]A LEFT JOIN [引數$" & Replace(Sheets("引數").Range(srtRange).Address, "$", "") & _
                    "]B ON A.[" & strItem & "尺碼]=B.[排序]" & _
                    " where [性別]='女'" & _
                    " group by [" & strItem & "尺碼],B.[序號]" & _
                    " ORDER BY B.[序號];"
' Debug.Print strSQLEmployees
rstEmployees.Open strSQLEmployees, Cnxn, adOpenStatic, adLockOptimistic, adCmdText
    Call QueryItemEx1(rstEmployees, "女" & strItem, intRow + 5)
Else
    strSQLEmployees = "SELECT [班級],sum(iif([性別]='男',[" & strItem & "訂購],0)) as boys,sum(iif([性別]='女',[" & strItem & "訂購],0)) as girls" & _
                    " FROM [帳務$]" & _
                    " group by [班級]" & _
                    " ORDER BY [班級];"
' Debug.Print strSQLEmployees
rstEmployees.Open strSQLEmployees, Cnxn, adOpenStatic, adLockOptimistic, adCmdText
    Call QueryItemEx2(rstEmployees, strItem, intRow)
End If
rstEmployees.Close
Set rstEmployees = Nothing
Cnxn.Close

End Sub

Public Sub QueryItemEx1(rstEmployees As ADODB.Recordset, strItem As Variant, intRow As Variant)
' rstEmployees      統計資料
' strItem           項目
' intRow            填表行位置
Dim intRowLoc As Integer
Dim fldSize, fldPeoples As Field
Dim cellsName, cellsData1 As Range
                    '填入項目的列數
    For intJ = 1 To WorksheetFunction.RoundUp(rstEmployees.RecordCount / FieldAmount, 0)    '行數目限制
      If Not intJ = 1 Then                                                                  'intJ表一範圍
        intRowLoc = intRow + (12 * (intJ - 1))
      Else
        intRowLoc = intRow
      End If
      Cells(intRowLoc, 1).value = strItem                                                   '項目名稱
Set fldSize = rstEmployees.Fields(0)
Set fldPeoples = rstEmployees.Fields(1)
        For intI = 1 To FieldAmount                                                         '行填入位置
Set cellsName = Range(Cells(intRowLoc, 2 + intI), Cells(intRowLoc, 2 + intI))               '欄位名稱
Set cellsData1 = Range(Cells(intRowLoc + 3, 2 + intI), Cells(intRowLoc + 3, 2 + intI))      '欄位資料
          If Not rstEmployees.EOF Then
            cellsName.value = IIf(fldSize = "0", "未定", fldSize)
            cellsData1.value = fldPeoples
          rstEmployees.MoveNext
          Else
                    '清除項目內容
            cellsName.ClearContents
            cellsData1.ClearContents
          End If
        Next intI
    Next intJ

End Sub

Public Sub QueryItemEx2(rstEmployees As ADODB.Recordset, strItem As Variant, intRow As Variant)
' rstEmployees      統計資料
' strItem           項目
' intRow            填表行位置
Dim intRowLoc As Integer
Dim fldClass, fldBoys, fldGirls As Field
Dim cellsName, cellsData1 As Range
                    '填入項目的列數
    For intJ = 1 To WorksheetFunction.RoundUp(rstEmployees.RecordCount / FieldAmount, 0)    '行數目限制
      If Not intJ = 1 Then                                                                  'intJ表一範圍
        intRowLoc = intRow + (12 * (intJ - 1))
      Else
        intRowLoc = intRow
      End If
      Cells(intRowLoc, 1).value = strItem                                                   '項目名稱
Set fldClass = rstEmployees.Fields(0)
Set fldBoys = rstEmployees.Fields(1)
Set fldGirls = rstEmployees.Fields(2)
        For intI = 1 To FieldAmount                                                         '行填入位置
Set cellsName = Range(Cells(intRowLoc, 2 + intI), Cells(intRowLoc, 2 + intI))               '欄位名稱
Set cellsData1 = Range(Cells(intRowLoc + 3, 2 + intI), Cells(intRowLoc + 3, 2 + intI))      '欄位資料
Set cellsData2 = Range(Cells(intRowLoc + 4, 2 + intI), Cells(intRowLoc + 4, 2 + intI))      '欄位資料
          If Not rstEmployees.EOF Then
            cellsName.value = IIf(fldClass = "0", "未定", fldClass)
            cellsData1.value = fldBoys
            cellsData2.value = fldGirls
          rstEmployees.MoveNext
          Else
                    '清除項目內容
            cellsName.ClearContents
            cellsData1.ClearContents
            cellsData2.ClearContents
          End If
        Next intI
    Next intJ

End Sub

Public Sub statClass(intRow As Variant, intDataRow As Variant)
' intRow    填表行位置
' intDataRow 填資料行列數
Dim rstClass As New ADODB.Recordset
Dim strSQLclass As String
Dim intRowLoc As Integer
Dim fldClass, fldBoys, fldGirls As Field
Dim cellsName, cellsData1, cellsData2 As Range
Dim Cnxn As ADODB.Connection
Set Cnxn = Cnxnopen(XLSfile, "1")

    strSQLclass = "SELECT [班級],sum(iif([性別]='男',1,0)) as boys,sum(iif([性別]='女',1,0)) as girls" & _
            " FROM [帳務$]" & _
            " group by [班級];"
'    Debug.Print strSQLclass
    rstClass.Open strSQLclass, Cnxn, adOpenStatic, adLockOptimistic, adCmdText
Set fldClass = rstClass.Fields(0)
Set fldBoys = rstClass.Fields(1)
Set fldGirls = rstClass.Fields(2)
    For intI = 1 To FieldAmount                                                             '行填入位置
Set cellsName = Range(Cells(intRow, 2 + intI), Cells(intRow, 2 + intI))                     '欄位名稱
Set cellsData1 = Range(Cells(intDataRow, 2 + intI), Cells(intDataRow, 2 + intI))            '欄位資料
Set cellsData2 = Range(Cells(intDataRow + 1, 2 + intI), Cells(intDataRow + 1, 2 + intI))    '欄位資料
      If Not rstClass.EOF Then
        cellsName.value = fldClass
        cellsData1.value = fldBoys
        cellsData2.value = fldGirls
        rstClass.MoveNext
      Else
        '清除項目內容
        cellsName.ClearContents
        cellsData1.ClearContents
        cellsData2.ClearContents
      End If
    Next intI
    rstClass.Close
    Cnxn.Close
    
End Sub