加入 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,207 @@
|
||||
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
|
||||
|
||||
|
||||
Reference in new issue
Block a user