208 lines
8.6 KiB
VB.net
208 lines
8.6 KiB
VB.net
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
|
|
|
|
|