加入 CodeStore VBA 模組

CodeStore/index.xlsm_Module1.bas

@@ -0,0 +1,198 @@
+Attribute VB_Name = "Module1"
+'**************** MySQL變數 ******************
+Const server_name = "ms1.tc-clothing.com"        ' 伺服器IP，127.0.0.1為目前本機
+Const database_name = "clothing"  ' 連線資料庫名稱
+Const user_id = "clothing"        ' 資料庫登入帳號
+Const UPassword = "clo256"         ' 資料庫登入密碼
+'********************************************
+Public PYEAR As Integer
+Public PCOMPANY As Integer
+Public XLSfile As String
+
+
+Public Function Cnmyopen() As ADODB.Connection
+Dim conn As New ADODB.Connection
+Dim connStr As String  '資料庫連線字串，其中5.3為ODBC驅動程式版本，要配合你安裝的驅動。
+    connStr = "DRIVER={MariaDB ODBC 3.2 Driver}" _
+                    & ";SERVER=" & server_name _
+                    & ";DATABASE=" & database_name _
+                    & ";UID=" & user_id _
+                    & ";PWD=" & UPassword
+    conn.Open connStr
+Set Cnmyopen = conn
+' 傳回Connection
+End Function
+
+Public Function Cnxnopen(strSQL As String, v_imex As String) As ADODB.Connection
+' strSQL 寫入檔案 v_imex 1=唯讀 0=寫入
+Dim conn As New ADODB.Connection
+Dim connStr As String  '資料庫連線字串
+    connStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Excel.ThisWorkbook.path & _
+        strSQL & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=" & v_imex & ";"";"
+    conn.Open connStr
+Set Cnxnopen = conn
+' 傳回Connection
+End Function
+
+Public Function rstCnxnopen(strXLSfile As String, strSQL As String) As ADODB.Recordset
+' 開啟Excel表
+Dim Cnxn As ADODB.Connection
+Dim rstXLS As New ADODB.Recordset
+Set Cnxn = Cnxnopen(strXLSfile, "1")
+    rstXLS.Open strSQL, Cnxn, adOpenStatic, adLockOptimistic, adCmdText
+Set rstCnxnopen = rstXLS
+' 傳回Recordset
+End Function
+
+Public Function rstCnmyopen(Cnmy As ADODB.Connection, strSQL As String) As ADODB.Recordset
+' 開啟Mysql表
+Dim rstSQL As ADODB.Recordset
+Set rstSQL = New ADODB.Recordset
+    rstSQL.CursorLocation = 3         'mysql RecordCount連線BUG by 藍色小舖 老頑童
+    rstSQL.Open strSQL, Cnmy
+Set rstCnmyopen = rstSQL
+' 傳回Recordset
+End Function
+
+Public Function sqlCnxnexec(strXLSfile As String, strSQL As String)
+' 執行SQL
+Dim cn As New ADODB.Connection
+' Dim Cnxn As ADODB.Connection
+' Set Cnxn = Cnxnopen(strXLSfile, "1")
+cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
+         "Data Source=" & Excel.ThisWorkbook.path & strXLSfile & ";" & _
+         "Extended Properties=""Excel 8.0;HDR=YES;IMEX=0"""
+cn.Execute strSQL
+
+End Function
+
+Public Sub truncate_data(Cnmy As ADODB.Connection, SQLYear As Variant, SQLCompany As Variant)
+' SQLYear 年度 SQLCompany 公司代碼
+Dim strSQL As String
+    strSQL = "delete FROM CUSTOMER where id BETWEEN " & SQLYear & SQLCompany & "0000 AND " & SQLYear & SQLCompany & "9999;"
+    ' debug.print strSQL
+    Cnmy.Execute strSQL     '刪除名冊
+    strSQL = "delete FROM SELLUP where id BETWEEN " & SQLYear & SQLCompany & "0000 AND " & SQLYear & SQLCompany & "9999;"
+    ' debug.print strSQL
+    Cnmy.Execute strSQL     '刪除購買
+' 清除舊資料
+End Sub
+
+Public Sub insert_data(Cnmy As ADODB.Connection, rstTBL As ADODB.Recordset, SQLYear As Variant, SQLCompany As Variant)
+' 匯入名冊資料 量身尺寸
+' rstTBL Excel檔案 SQLYear 年度 SQLCompany 公司
+Dim sb As StringBuilder
+Set sb = New StringBuilder
+'====================================+
+Dim p As Long                       '+
+Dim diag As New ProgressDialogue    '+
+'====================================+
+' 建立正規表示法變數
+Dim Regex As New RegExp
+'===================================================================================+
+p = 0                                                                              '+
+diag.Configure "更新資料時間", "Now wasting your time...", 0, rstTBL.RecordCount    '+
+diag.Show                                                                          '+
+'===================================================================================+
+    sb.Append "INSERT INTO CUSTOMER(id,regdate,company,department,seat,cus_no,cus_name,cus_sex,chest,waist,hip,leg,height,weight,trousers,tailor) VALUES "
+    While Not rstTBL.EOF
+        With rstTBL.Fields
+            If Not IsNull(.item("c_name")) Then
+                sb.Append "(" & .item("ID") & ","               'Field id
+                sb.Append "'" & .item("regdate") & "',"         'Field regdate
+                sb.Append "" & .item("company") & ","           'Field company
+                sb.Append "" & .item("depart") & ","            'Field department
+                sb.Append "" & .item("seat") & ","              'Field seat
+                sb.Append "'" & .item("cus_no") & "',"          'Field cus_no
+                ' 設定匹配規則
+                Regex.Pattern = "[^\u4E00-\u9FA5\u3000-\u303F\uFF00-\uFFEF\u0000-\u007F\u201c-\u201d]"
+                If Regex.test(.item("c_name")) Then Debug.Print .item("ID")
+                sb.Append "'" & .item("c_name") & "',"          'Field cus_name
+                sb.Append "" & .item("sex") & ","               'Field cus_sex
+                sb.Append "" & .item("chest") & ","             'Field chest
+                sb.Append "" & .item("waist") & ","             'Field waist
+                sb.Append "" & .item("hip") & ","               'Field hip
+                sb.Append "" & .item("leg") & ","               'Field leg
+                sb.Append "" & .item("height") & ","            'Field height
+                sb.Append "" & .item("weight") & ","            'Field weight
+                sb.Append "" & .item("trousers") & ","          'Field trousers
+                sb.Append "" & .item("tailor") & ")"           'Field tailor
+            End If
+        End With
+        rstTBL.MoveNext
+        If Not rstTBL.EOF Then sb.Append ","
+'================================================+
+diag.SetValue p                                 '+
+diag.SetStatus "Now wasting your time... " & p  '+
+p = p + 1                                       '+
+'================================================+
+    Wend
+    ' strSQL = Left(strSQL, Len(strSQL) - 1)
+' Debug.Print sb.tostring
+    Cnmy.Execute sb.ToString
+'============+
+diag.Hide   '+
+'============+
+'更新服裝尺碼
+    ' Application.Calculation = xlAutomatic ' 設置自動重算
+    ' MsgBox "更新完成！"
+End Sub
+
+Public Sub insert_data2(Cnmy As ADODB.Connection, rstXLS As ADODB.Recordset, SQLYear As Variant, SQLCompany As Variant)
+' 新增資料段2 服裝尺碼
+Dim sb As StringBuilder
+Set sb = New StringBuilder
+Dim rstGoodsUse As New ADODB.Recordset
+' Debug.Print rstXLS!itsz1,rstXLS!item1
+    strSQL = "Select pno,mtmodel,mtname,mtcolor,wtmodel,wtname,wtcolor,tomeasure" & _
+            " FROM GoodsUse" & _
+            " WHERE corp_use=" & SQLCompany & _
+            " and Depart_Use=(select department from CUSTOMER" & _
+            " where id BETWEEN " & SQLYear & SQLCompany & "0000 AND " & SQLYear & SQLCompany & "9999" & _
+            " limit 1)order by pno"
+    rstGoodsUse.CursorLocation = 3          'mysql RecordCount連線BUG by 藍色小舖 老頑童
+    rstGoodsUse.Open strSQL, Cnmy
+' Debug.Print rstGoodsUse.RecordCount
+    ItCount = rstGoodsUse.RecordCount       '處理項目數
+    sb.Append "insert into SELLUP(id"
+    For i = 1 To ItCount
+        sb.Append "," & "itsz" & i & ",item" & i
+    Next i
+    sb.Append ") VALUES "
+    '資料來源動態設定
+    While Not rstXLS.EOF
+        sb.Append "(" & rstXLS!ID & ","
+        rstGoodsUse.MoveFirst
+        i = 1
+        While Not rstGoodsUse.EOF
+            sb.Append "goodsid('" & rstXLS.Fields.item("itsz" & i) & "'," & IIf(rstXLS!sex, rstGoodsUse!mtmodel, rstGoodsUse!wtmodel) & ")," & _
+                    rstXLS.Fields.item("item" & i)
+            i = i + 1
+            rstGoodsUse.MoveNext
+            If Not rstGoodsUse.EOF Then sb.Append ","
+        Wend
+        sb.Append ")"
+        rstXLS.MoveNext
+        If Not rstXLS.EOF Then sb.Append ","
+    Wend
+    sb.Append ";"
+' Debug.Print sb.tostring
+    Cnmy.Execute sb.ToString
+rstGoodsUse.Close
+' 完成資料新增
+End Sub
+
+Public Sub XLS_init()
+' debug.print Worksheets("售價").Cells(3, 11)
+    PYEAR = Worksheets("售價").Cells(3, 11)
+' debug.print Worksheets("售價").Cells(5, 11)
+    PCOMPANY = Worksheets("售價").Cells(5, 11)
+' debug.print Worksheets("售價").Cells(7, 11)
+    XLSfile = Worksheets("售價").Cells(7, 11)
+End Sub
+
+
+
+
+
+

CodeStore/index.xlsm_MyRibbon.bas

@@ -0,0 +1,157 @@
+Attribute VB_Name = "MyRibbon"
+
+'namespace=vba-files/ribbons
+
+'/*
+'[Ribbon Menu Action]
+'Ribbon Buttom 1 example call code
+'
+'*/
+Public Sub btn1(ByRef control As Office.IRibbonControl)
+    On Error GoTo ErrorHandler
+    
+    Dim wb1 As Workbook, wb2 As Workbook
+    Dim ws1 As Worksheet, ws2 As Worksheet
+    Dim PYEAR As String, PCOMPANY As String, XLSfile As String
+    Dim TM As Double, xRow As Long
+    
+    ' 初始化變數
+    InitializeVariables PYEAR, PCOMPANY, XLSfile
+    
+    ' 打開工作簿
+    Set wb1 = OpenWorkbook(Excel.ThisWorkbook.path & "\..\..\制服明細.xlsx")
+    Set wb2 = OpenWorkbook(Excel.ThisWorkbook.path & XLSfile)
+    
+    ' 設置工作表
+    Set ws1 = wb1.Sheets("Sheet1")
+    Set ws2 = wb2.Sheets("名冊")
+    
+    ' 執行主要操作
+    TM = Timer
+    xRow = 10000
+    ProcessData ws1, ws2, xRow
+    
+    ' 顯示執行時間
+    ws2.Range("AL1").value = Timer - TM
+    
+    ' 關閉工作簿
+    wb1.Close SaveChanges:=False
+    wb2.Close SaveChanges:=True
+    
+    Exit Sub
+    
+ErrorHandler:
+    MsgBox "發生錯誤: " & Err.Description, vbCritical
+    On Error Resume Next
+    If Not wb1 Is Nothing Then wb1.Close SaveChanges:=False
+    If Not wb2 Is Nothing Then wb2.Close SaveChanges:=False
+End Sub
+
+Private Sub InitializeVariables(ByRef PYEAR As String, ByRef PCOMPANY As String, ByRef XLSfile As String)
+    With ThisWorkbook.Worksheets("售價")
+        PYEAR = .Cells(3, 11).value
+        PCOMPANY = .Cells(5, 11).value
+        XLSfile = .Cells(7, 11).value
+    End With
+End Sub
+
+Private Function OpenWorkbook(ByVal path As String) As Workbook
+    Set OpenWorkbook = Workbooks.Open(path)
+End Function
+
+Private Sub ProcessData(ByRef ws1 As Worksheet, ByRef ws2 As Worksheet, ByVal xRow As Long)
+    Dim arr As Variant, Brr As Variant, Crr As Variant
+    Dim xD As Object
+    Dim i As Long
+    
+    ' 清除舊數據
+    ws2.Columns("AK:AK").Clear
+    ws2.Range("AL1").value = ""
+    
+    ' 獲取數據
+    arr = ws2.Range("F1").Resize(xRow)
+    Brr = ws1.Range("A1:F1").Resize(xRow)
+    Crr = Range("idx班代碼").Resize(xRow)
+    
+    ' 創建字典並填充數據
+    Set xD = CreateObject("Scripting.Dictionary")
+    FillDictionary xD, Crr, Brr
+    
+    ' 更新 Arr 數據
+    For i = 1 To UBound(arr)
+        If xD.Exists(arr(i, 1)) Then
+            arr(i, 1) = xD(arr(i, 1))
+        End If
+    Next i
+    
+    ' 將結果寫回工作表
+    ws2.Range("AK1").Resize(xRow) = arr
+End Sub
+
+Private Sub FillDictionary(ByRef xD As Object, ByRef Crr As Variant, ByRef Brr As Variant)
+    Dim i As Long
+    
+    For i = 1 To UBound(Crr)
+        If Not IsEmpty(Crr(i, 1)) Then xD(Crr(i, 1)) = Crr(i, 2)
+    Next i
+    
+    For i = 1 To UBound(Brr)
+        If Not IsEmpty(Brr(i, 6)) Then xD(Brr(i, 6)) = Brr(i, 4)
+    Next i
+End Sub
+
+'/*
+'[Ribbon Menu Action]
+'Ribbon Buttom 2 example call code
+'
+'*/
+Public Sub btn2(ByRef control As Office.IRibbonControl)
+' PYEAR 年度 PCOMPANY 公司代碼 XLSfile 同步檔案
+Dim Cnmy As ADODB.Connection
+Dim rstXLS As New ADODB.Recordset
+Dim strSQL As String
+Set Cnmy = Cnmyopen()
+    PYEAR = Worksheets("售價").Cells(3, 11)
+    PCOMPANY = Worksheets("售價").Cells(5, 11)
+    XLSfile = Worksheets("售價").Cells(7, 11)
+Call truncate_data(Cnmy, PYEAR, PCOMPANY)
+    strSQL = "Select " & PYEAR & PCOMPANY & " & Format([編號],'0000') AS ID,Format(date(), 'yyyy-mm-dd') as regdate, company,[編號] as studentid,[班ID] as depart,[座號] as seat,[姓名] as c_name, IIf([性別]='男','true','false') AS sex" _
+            & ",[胸] as chest, [腰] as waist,[臀] as hip, [長] as leg,[身] as height,[重] as weight, [褲長] as trousers" _
+            & ",[學號] as cus_no,IIf([選取]='a','true','false') as tailor" _
+            & " FROM [帳務$] order by [編號];"
+' Debug.Print strSQL
+Set rstXLS = rstCnxnopen(XLSfile, strSQL)
+Call insert_data(Cnmy, rstXLS, PYEAR, PCOMPANY)
+rstXLS.Close
+    strSQL = "Select " & PYEAR & PCOMPANY & " & Format([編號],'0000') AS ID,IIf([性別]='男',true,false) AS sex" & _
+        ", [校短尺碼] as itsz1, [校短訂購] as item1, [校長尺碼] as itsz2, [校長訂購] as item2" & _
+        ", [校夏尺碼] as itsz3, [校夏訂購] as item3, [校冬尺碼] as itsz4, [校冬訂購] as item4, [校裙尺碼] as itsz5, [校裙訂購] as item5" & _
+        ", [背心尺碼] as itsz6, [背心訂購] as item6, 'A' as itsz7, [領帶訂購] as item7, 'A' as itsz8, [腰帶訂購] as item8" & _
+        ", 'A' as itsz9, [書包訂購] as item9" & _
+        " FROM [帳務$];"
+' Debug.Print strSQL
+Set rstXLS = rstCnxnopen(XLSfile, strSQL)
+Call insert_data2(Cnmy, rstXLS, PYEAR, PCOMPANY)
+rstXLS.Close
+Cnmy.Close
+' 執行SQL上傳
+End Sub
+
+
+'/*
+'[Ribbon Menu Action]
+'Ribbon Buttom 2 example call code
+'
+'*/
+Public Sub btn3(ByRef control As Office.IRibbonControl)
+
+    PYEAR = Worksheets("售價").Cells(3, 11)
+    PCOMPANY = Worksheets("售價").Cells(5, 11)
+    XLSfile = Worksheets("售價").Cells(7, 11)
+
+End Sub
+
+
+
+
+

CodeStore/index.xlsm_ProgressDialogue.bas

@@ -0,0 +1,101 @@
+Attribute VB_Name = "ProgressDialogue"
+Option Explicit
+
+Dim Cancelled As Boolean, showTime As Boolean, showTimeLeft As Boolean
+Dim startTime As Long
+Dim BarMin As Long, BarMax As Long, BarVal As Long
+
+Private Declare PtrSafe Function GetTickCount Lib "Kernel32" () As Long
+
+'Title will be the title of the dialogue.
+'Status will be the label above the progress bar, and can be changed with SetStatus.
+'Min is the progress bar minimum value, only set by calling configure.
+'Max is the progress bar maximum value, only set by calling configure.
+'CancelButtonText is the caption of the cancel button. If set to vbNullString, it is hidden.
+'optShowTimeElapsed controls whether the progress bar computes and displays the time elapsed.
+'optShowTimeRemaining controls whether the progress bar estimates and displays the time remaining.
+'calling Configure sets the current value equal to Min.
+'calling Configure resets the current run time.
+Public Sub Configure(ByVal title As String, ByVal status As String, _
+                     ByVal Min As Long, ByVal Max As Long, _
+                     Optional ByVal CancelButtonText As String = "Cancel", _
+                     Optional ByVal optShowTimeElapsed As Boolean = True, _
+                     Optional ByVal optShowTimeRemaining As Boolean = True)
+    Me.Caption = title
+    lblStatus.Caption = status
+    BarMin = Min
+    BarMax = Max
+    BarVal = Min
+    CancelButton.Visible = Not CancelButtonText = vbNullString
+    CancelButton.Caption = CancelButtonText
+    startTime = GetTickCount
+    showTime = optShowTimeElapsed
+    showTimeLeft = optShowTimeRemaining
+    lblRunTime.Caption = ""
+    lblRemainingTime.Caption = ""
+    Cancelled = False
+End Sub
+
+'Set the label text above the status bar
+Public Sub SetStatus(ByVal status As String)
+    lblStatus.Caption = status
+    DoEvents
+End Sub
+
+'Set the value of the status bar, a long which is snapped to a value between Min and Max
+Public Sub SetValue(ByVal value As Long)
+    If value < BarMin Then value = BarMin
+    If value > BarMax Then value = BarMax
+    Dim progress As Double, runTime As Long
+    BarVal = value
+    progress = (BarVal - BarMin) / (BarMax - BarMin)
+    ProgressBar.Width = 292 * progress
+    lblPercent = Int(progress * 10000) / 100 & "%"
+    runTime = GetRunTime()
+    If showTime Then lblRunTime.Caption = "Time Elapsed: " & GetRunTimeString(runTime, True)
+    If showTimeLeft And progress > 0 Then _
+        lblRemainingTime.Caption = "Est. Time Left: " & GetRunTimeString(runTime * (1 - progress) / progress, False)
+    DoEvents
+End Sub
+
+'Get the time (in milliseconds) since the progress bar "Configure" routine was last called
+Public Function GetRunTime() As Long
+    GetRunTime = GetTickCount - startTime
+End Function
+
+'Get the time (in hours, minutes, seconds) since "Configure" was last called
+Public Function GetFormattedRunTime() As String
+    GetFormattedRunTime = GetRunTimeString(GetTickCount - startTime)
+End Function
+
+'Formats a time in milliseconds as hours, minutes, seconds.milliseconds
+'Milliseconds are excluded if showMsecs is set to false
+Private Function GetRunTimeString(ByVal runTime As Long, Optional ByVal showMsecs As Boolean = True) As String
+    Dim msecs&, hrs&, mins&, secs#
+    msecs = runTime
+    hrs = Int(msecs / 3600000)
+    mins = Int(msecs / 60000) - 60 * hrs
+    secs = msecs / 1000 - 60 * (mins + 60 * hrs)
+    GetRunTimeString = IIf(hrs > 0, hrs & " hours ", "") _
+                     & IIf(mins > 0, mins & " minutes ", "") _
+                     & IIf(secs > 0, IIf(showMsecs, secs, Int(secs + 0.5)) & " seconds", "")
+End Function
+
+'Returns the current value of the progress bar
+Public Function GetValue() As Long
+    GetValue = BarVal
+End Function
+
+'Returns whether or not the cancel button has been pressed.
+'The ProgressDialogue must be polled regularily to detect whether cancel was pressed.
+Public Function cancelIsPressed() As Boolean
+    cancelIsPressed = Cancelled
+End Function
+
+'Recalls that cancel was pressed so that they calling routine can be notified next time it asks.
+Private Sub CancelButton_Click()
+    Cancelled = True
+    lblStatus.Caption = "Cancelled By User. Please Wait."
+End Sub
+
+

CodeStore/index.xlsm_StringBuilder.bas

@@ -0,0 +1,46 @@
+Attribute VB_Name = "StringBuilder"
+Option Compare Text
+Option Explicit
+
+Dim MyBuffer() As String
+Dim MyCurrentIndex As Long
+Dim MyMaxIndex As Long
+
+Private Sub Class_Initialize()
+
+    Clear
+
+End Sub
+
+Public Sub Clear()
+    MyCurrentIndex = 0
+    MyMaxIndex = 16
+    ReDim MyBuffer(1 To MyMaxIndex)
+End Sub
+
+'Appends the given Text to this StringBuilder
+Public Sub Append(Text As String)
+
+    MyCurrentIndex = MyCurrentIndex + 1
+
+    If MyCurrentIndex > MyMaxIndex Then
+        MyMaxIndex = 2 * MyMaxIndex
+        ReDim Preserve MyBuffer(1 To MyMaxIndex)
+    End If
+    MyBuffer(MyCurrentIndex) = Text
+
+End Sub
+
+'Returns the text in this StringBuilder
+'Optional Parameter: Separator (default vbNullString) used in joining components
+Public Function ToString(Optional Separator As String = vbNullString) As String
+
+    If MyCurrentIndex > 0 Then
+        ReDim Preserve MyBuffer(1 To MyCurrentIndex)
+        MyMaxIndex = MyCurrentIndex
+        ToString = Join(MyBuffer, Separator)
+    End If
+
+End Function
+
+

CodeStore/index.xlsm_ThisWorkbook.bas

@@ -0,0 +1,7 @@
+Attribute VB_Name = "ThisWorkbook"
+Private Sub Workbook_Open()
+' 自動執行
+    Call XLS_init
+    Application.Caption = PYEAR & Worksheets("售價").Cells(3, 1)
+End Sub
+

CodeStore/index.xlsm_clsConcat.bas

@@ -0,0 +1,334 @@
+Attribute VB_Name = "clsConcat"
+Option Compare Binary
+Option Explicit
+
+' String concatenation (joining strings together) can have a significant
+' performance impact when you are using the ampersand character to join
+' strings together. While negligible in occasional use, if you start
+' running tens of thousands of these in a loop, it can really bog
+' down the processing due to the memory reallocations happening behind
+' the scenes. In those cases it is better to use the Mid$() function to
+' change an existing buffer to build the return string.
+
+' Special thanks to Nir Sofer - http://www.nirsoft.net/vb/strclass.html
+' and Chris Lucas - http://www.planetsourcecode.com/vb/scripts/ShowCode.asp?txtCodeId=37141&lngWId=1
+' for their inspiration with these concepts.
+
+' Set this to any character or string to add after each
+' call to `.Add()`. A common example would be vbCrLf.
+Public AppendOnAdd As String
+
+' Set up an array of pages to hold strings
+Private astrPages() As String
+Private lngCurrentPage As Long
+Private lngCurrentPos As Long
+Private lngPageSize As Long
+Private lngInitialPages As Long
+
+' These defaults can be tweaked as needed
+Const clngPageSize As Long = 4096
+Const clngInitialPages As Long = 100
+
+
+
+' Prepares the initial buffer page
+Private Sub Class_Initialize()
+
+    If lngPageSize = 0 Then lngPageSize = clngPageSize
+    If lngInitialPages = 0 Then lngInitialPages = clngInitialPages
+
+    ' Set up the initial array of pages.
+    ReDim astrPages(0 To lngInitialPages - 1) As String
+
+    ' Prepare first page
+    astrPages(0) = Space$(lngPageSize)
+
+End Sub
+
+
+' Add 1 or more strings (avoiding the string conversion of paramarray)
+Public Sub Add(str1 As String, Optional str2 As String, Optional str3 As String, Optional str4 As String, Optional str5 As String, _
+    Optional str6 As String, Optional str7 As String, Optional str8 As String, Optional str9 As String, Optional str10 As String)
+    If str1 <> vbNullString Then AddString str1
+    If str2 <> vbNullString Then AddString str2
+    If str3 <> vbNullString Then AddString str3
+    If str4 <> vbNullString Then AddString str4
+    If str5 <> vbNullString Then AddString str5
+    If str6 <> vbNullString Then AddString str6
+    If str7 <> vbNullString Then AddString str7
+    If str8 <> vbNullString Then AddString str8
+    If str9 <> vbNullString Then AddString str9
+    If str10 <> vbNullString Then AddString str10
+    AddString AppendOnAdd
+End Sub
+
+
+' Add to the string buffer
+Private Sub AddString(strAddString As String)
+
+    Dim lngLen          As Long
+    Dim lngRemaining    As Long
+    Dim lngAddStrPos    As Long
+    Dim lngAddLen       As Long
+
+    ' Get length of new string
+    lngLen = Len(strAddString)
+
+    ' No need to process a zero-length string
+    If lngLen > 0 Then
+        ' Set starting position for string we are adding
+        lngAddStrPos = 1
+
+        ' Continue filling pages till we reach the end of the new string
+        Do While lngAddStrPos <= lngLen
+
+            ' Check to see if we need a new page
+            If lngCurrentPos = lngPageSize Then
+                ' See if we already have a new page available in the array
+                If lngCurrentPage = UBound(astrPages) Then
+                    ' Need to add a page to the array.
+                    ReDim Preserve astrPages(0 To lngCurrentPage + 1)
+                End If
+                ' Prepare page as a buffer
+                lngCurrentPage = lngCurrentPage + 1
+                astrPages(lngCurrentPage) = Space$(lngPageSize)
+                lngCurrentPos = 0
+            End If
+
+            ' See if it fits on the current page
+            lngRemaining = lngPageSize - lngCurrentPos
+            If (lngLen - (lngAddStrPos - 1)) <= lngRemaining Then
+                ' Yes, add to current page.
+                lngAddLen = (lngLen - (lngAddStrPos - 1))
+                Mid$(astrPages(lngCurrentPage), lngCurrentPos + 1, lngAddLen) = Mid$(strAddString, lngAddStrPos)
+                lngAddStrPos = lngLen + 1
+                lngCurrentPos = lngCurrentPos + lngAddLen
+            Else
+                ' Fill remaining available space on current page.
+                Mid$(astrPages(lngCurrentPage), lngCurrentPos + 1, lngRemaining) = Mid$(strAddString, lngAddStrPos, lngRemaining)
+                ' Note position in new string
+                lngCurrentPos = lngPageSize
+                lngAddStrPos = lngAddStrPos + lngRemaining
+            End If
+
+        ' Move to next page, if needed
+        Loop
+
+    End If
+
+End Sub
+
+
+' Removes the specified number of chacters from the string.
+' (Technically just moves the position back)
+Public Sub Remove(lngChars As Long)
+
+    Dim lngTotalLen As Long
+    Dim lngNewPosition As Long
+
+    ' Get total length of current string including all pages
+    lngTotalLen = lngCurrentPos + (lngCurrentPage * lngPageSize)
+
+    ' We can't remove more characters than we put in the string to start with.
+    If lngChars > lngTotalLen Then
+        ' Go to beginning
+        lngCurrentPage = 0
+        lngCurrentPos = 1
+    Else
+        ' Get new absolute position
+        lngNewPosition = lngTotalLen - lngChars
+        ' Calculate full pages
+        lngCurrentPage = (lngNewPosition \ lngPageSize)
+        ' Set position on partial page
+        lngCurrentPos = lngNewPosition - (lngCurrentPage * lngPageSize)
+    End If
+
+End Sub
+
+
+' Returns the accumulated string
+Public Function GetStr() As String
+
+    Dim lngCnt As Long
+
+    ' Prepare return string. This should be the filled pages plus the last
+    ' partial page, divided by 2 to get the string length instead of byte length.
+    GetStr = Space$((lngCurrentPage * lngPageSize) + lngCurrentPos)
+
+    ' Loop through filled pages, overlaying on return string.
+    ' (Last partial page is automatically trimmed based on returned string size.)
+    ' (If lngCurrentPos=0 then skip last page)
+    If Len(GetStr) > 0 Then
+        For lngCnt = 0 To lngCurrentPage - Abs(CBool(lngCurrentPos = 0))
+            Mid$(GetStr, (lngCnt * lngPageSize) + 1, lngPageSize) = astrPages(lngCnt)
+        Next lngCnt
+    End If
+
+End Function
+
+
+' Return a partial string from a specified position
+Public Function MidStr(lngStart As Long, Optional lngLength As Long = -1) As String
+
+    Dim lngPage As Long
+    Dim lngPos As Long
+    Dim lngStartPage As Long
+    Dim lngStartPos As Long
+
+    ' Prepare return string length.
+    If lngLength = -1 Then
+        ' Return remaining string after lngStart
+        lngLength = (Length - lngStart) + 1
+        MidStr = Space$(lngLength)
+    Else
+        ' Return a specified number of characters
+        MidStr = Space$(lngLength)
+    End If
+
+    ' Determine start page and position for return string
+    lngStartPage = (lngStart - 1) \ lngPageSize ' Zero based page
+    lngStartPos = lngStart - (lngStartPage * lngPageSize)
+
+    ' Loop through filled pages, overlaying on return string.
+    ' (Last partial page is automatically trimmed based on returned string size.)
+    If Len(MidStr) > 0 Then
+        For lngPage = lngStartPage To lngCurrentPage
+            ' Could start at any point on first page
+            If lngPage = lngStartPage Then
+                Mid$(MidStr, 1) = Mid$(astrPages(lngPage), lngStartPos)
+                ' lngPos is the current position in the new string
+                lngPos = lngPageSize - (lngStartPos - 2)
+            Else
+                ' Pull whole pages as needed
+                Mid$(MidStr, lngPos) = astrPages(lngPage)
+                lngPos = lngPos + lngPageSize
+            End If
+            ' Exit when we have filled the requested string.
+            If lngPos > lngLength Then Exit For
+        Next lngPage
+    End If
+
+End Function
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : RTrim
+' Author    : Adam Waller
+' Date      : 8/14/2023
+' Purpose   : Trim trailing whitespace from content
+'---------------------------------------------------------------------------------------
+'
+Public Function RTrim(Optional strTrimChars As String = " ")
+    Do
+        If Length < Len(strTrimChars) Then Exit Do
+        If RightStr(Len(strTrimChars)) = strTrimChars Then
+            Remove Len(strTrimChars)
+        Else
+            Exit Do
+        End If
+    Loop
+End Function
+
+
+'---------------------------------------------------------------------------------------
+' Procedure : Right
+' Author    : Adam Waller
+' Date      : 11/5/2020
+' Purpose   : Return the rightmost specified number of characters.
+'---------------------------------------------------------------------------------------
+'
+Public Function RightStr(lngLength As Long) As String
+    If Length > lngLength Then
+        RightStr = MidStr((Length - lngLength) + 1)
+    Else
+        RightStr = GetStr
+    End If
+End Function
+
+
+' returns the length of the string, based on the current position
+' (Faster than building the string just to check the length)
+Public Function Length() As Double
+    Length = (lngCurrentPage * lngPageSize) + lngCurrentPos
+End Function
+
+
+' Reset the buffer without changing the page size
+Public Sub Clear()
+
+    Class_Initialize
+
+    ' Reset positions
+    lngCurrentPage = 0
+    lngCurrentPos = 0
+
+End Sub
+
+
+' Manually set page size if you want something different from the default.
+Public Sub SetPageSize(lngNewPageSize As Long, Optional lngNewInitialPages As Long)
+    If lngCurrentPage > 0 Or lngCurrentPos > 1 Then
+        MsgBox "Please set the page size before adding any data", vbExclamation, "Error in clsConcat"
+    Else
+        lngPageSize = lngNewPageSize
+        If lngNewInitialPages > 0 Then lngInitialPages = lngNewInitialPages
+        ' Reinitialize with the updated sizes
+        Class_Initialize
+    End If
+End Sub
+
+
+' Test the class to make sure we are paging correctly.
+Public Sub SelfTest()
+
+    SetPageSize 10, 5
+
+    Debug.Assert UBound(astrPages) = 4
+    Add "abcdefghij"
+    Add "k"
+    Debug.Assert Len(GetStr) = 11
+    Debug.Assert Length = 11
+    Remove 2
+    Debug.Assert Len(GetStr) = 9
+    Add "jkl"
+    Debug.Assert Len(GetStr) = 12
+    Debug.Assert GetStr = "abcdefghijkl"
+    Add "m123456789"
+    Remove 11
+    Debug.Assert GetStr = "abcdefghijk"
+    Debug.Assert MidStr(1, 1) = "a"
+    Debug.Assert MidStr(11, 1) = "k"
+    Debug.Assert MidStr(2, 3) = "bcd"
+    Debug.Assert MidStr(8) = "hijk"
+    Debug.Assert MidStr(10, 1) = "j"
+    Debug.Assert RightStr(1) = "k"
+    Debug.Assert RightStr(100) = "abcdefghijk"
+
+    ' Verify paging
+        Clear
+        SetPageSize 5, 2
+        Add "1234"
+        Debug.Assert GetStr = "1234"
+        Add "5"
+        Debug.Assert GetStr = "12345"
+        Add "6"
+        Debug.Assert GetStr = "123456"
+        Add "789"
+        Debug.Assert GetStr = "123456789"
+        Add "0"
+        Debug.Assert GetStr = "1234567890"
+        Add "A"
+        Debug.Assert GetStr = "1234567890A"
+        Remove 1
+        Debug.Assert GetStr = "1234567890"
+        Remove 1
+        Debug.Assert GetStr = "123456789"
+        Add "0A"
+        Debug.Assert GetStr = "1234567890A"
+        Remove 2
+        Debug.Assert GetStr = "123456789"
+        Add "0A"
+        Debug.Assert GetStr = "1234567890A"
+End Sub
+
+

CodeStore/index.xlsm_stdArray.bas

@@ -0,0 +1,870 @@
+Attribute VB_Name = "stdArray"
+'@TODO:
+'* Implement Exceptions throughout all Array functions.
+'* Fully implement pInitialised where necessary.
+'* Build Methods Slice; Splice; Sort
+'* Add methods from ruby
+'* Documentation of methods
+
+#If VBA6 Then
+  Private Declare PtrSafe Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As Long)
+#Else
+  Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
+#End If
+Private Enum SortDirection
+    Ascending = 1
+    Descending = 2
+End Enum
+Private Type SortStruct
+  value As Variant
+  sortValue As Variant
+End Type
+
+Private pArr() As Variant
+Private pProxyLength As Long
+Private pLength As Long
+
+Private pChunking As Long
+Private pInitialised As Boolean
+
+
+
+Public Event BeforeArrLet(ByRef arr As stdArray, ByRef arr As Variant)
+Public Event AfterArrLet(ByRef arr As stdArray, ByRef arr As Variant)
+Public Event BeforeAdd(ByRef arr As stdArray, ByVal iIndex As Long, ByRef item As Variant, ByRef cancel As Boolean)
+Public Event AfterAdd(ByRef arr As stdArray, ByVal iIndex As Long, ByRef item As Variant)
+Public Event BeforeRemove(ByRef arr As stdArray, ByVal iIndex As Long, ByRef item As Variant, ByRef cancel As Boolean)
+Public Event AfterRemove(ByRef arr As stdArray, ByVal iIndex As Long)
+Public Event AfterClone(ByRef Clone As stdArray)
+Public Event AfterCreate(ByRef arr As stdArray)
+
+'Create a stdArray object from params
+'@param {paramarray variant()} The items of the array
+'@returns {stdArray<variant>} A stdArray from the parameters.
+Public Function Create(ParamArray params() As Variant) As stdArray
+    Set Create = New stdArray
+    
+    Dim i As Long
+    Dim lb As Long: lb = LBound(params)
+    Dim ub As Long: ub = UBound(params)
+    
+    Call Create.Init(ub - lb + 1, 10)
+    
+    For i = lb To ub
+        Call Create.Push(params(i))
+    Next
+
+    'Raise AfterCreate event
+    RaiseEvent AfterCreate(Create)
+End Function
+
+'Create a stdArray object from params
+'@param {Long} The length of the initial private array created
+'@param {Long} The number of items the private array is increased by when required.
+'@param {paramarray variant()} The items of the array
+'@returns {stdArray<variant>} A stdArray from the parameters.
+Public Function CreateWithOptions(ByVal iInitialLength As Long, ByVal iChunking As Long, ParamArray params() As Variant) As stdArray
+    Set CreateWithOptions = New stdArray
+    
+    Dim i As Long
+    Dim lb As Long: lb = LBound(params)
+    Dim ub As Long: ub = UBound(params)
+    
+    Call CreateWithOptions.Init(iInitialLength, iChunking)
+    For i = lb To ub
+        Call CreateWithOptions.Push(params(i))
+    Next
+
+    'Raise AfterCreate event
+    RaiseEvent AfterCreate(Create)
+End Function
+
+'Create a stdArray object from a VBA array
+'@param {variant()} Variant array to create a `stdArray` object from.
+'@returns {stdArray<variant>} Returns `stdArray` of variants.
+Public Function CreateFromArray(ByVal arr As Variant) As stdArray
+    Set CreateFromArray = New stdArray
+    
+    Dim i As Long
+    Dim lb As Long: lb = LBound(arr)
+    Dim ub As Long: ub = UBound(arr)
+    Call CreateFromArray.Init(ub - lb + 1, 10)
+    
+    For i = lb To ub
+        Call CreateFromArray.Push(arr(i))
+    Next
+
+    'Raise AfterCreate event
+    RaiseEvent AfterCreate(Create)
+End Function
+
+'Create an array by splitting a string
+'@param {string}      Haystack to split
+'@param {string?=","} Delimiter
+'@returns {stdArray<string>} A list of strings
+Public Function CreateFromString(ByVal sHaystack As String, Optional ByVal sDelimiter As String = ",") As stdArray
+  Set CreateFromString = CreateFromArray(Split(sHaystack, sDelimiter))
+End Function
+
+'Initialise array
+'@param {Long} The length of the initial private array created
+'@param {Long} The number of items the private array is increased by when required.
+Friend Sub Init(ByVal iInitialLength As Long, ByVal iChunking As Long)
+  If iChunking > iInitialLength Then iInitialLength = iChunking
+  If Not pInitialised Then
+    pProxyLength = iInitialLength
+    ReDim pArr(1 To iInitialLength) As Variant
+    pChunking = iChunking
+    pInitialised = True
+  End If
+End Sub
+
+'Obtain a collection from the data contained within the array. Primarily used for NewEnum() method.
+'@returns {Collection} Collection from Array
+Public Function AsCollection() As collection
+  Set AsCollection = New collection
+  Dim i As Long
+  For i = 1 To Length()
+    AsCollection.Add pArr(i)
+  Next
+End Function
+
+'For-each compatibility
+'@protected
+'@returns {IEnumVARIANT} An enumerator with methods enumNext, enumRefresh etc.
+'@usage `For each obj in myEnum: ... : next`
+'@TODO: Use custom IEnumVARIANT instead of casting to Collection
+Public Property Get NewEnum() As IUnknown
+    Static oEnumCol As collection: If oEnumCol Is Nothing Then Set oEnumCol = AsCollection()
+    Set NewEnum = oEnumCol.[_NewEnum]
+End Property
+
+'Obtain the length of the array
+Public Property Get Length() As Long
+    Length = pLength
+End Property
+
+'Obtain the length of the private array which stores the data of this array class
+Public Property Get zProxyLength() As Long
+    zProxyLength = pProxyLength
+End Property
+
+'Resize the array to a length
+'@param {Long} The length of the desired array
+Public Sub Resize(ByVal iLength As Long)
+  pLength = iLength
+End Sub
+
+'Rechunk the private array to the length / number of items.
+Public Sub Rechunk()
+  Dim fNumChunks As Double, iNumChunks As Long
+  fNumChunks = pLength / pChunking
+  iNumChunks = CLng(fNumChunks)
+  If fNumChunks > iNumChunks Then iNumChunks = iNumChunks + 1
+  
+  ReDim Preserve pArr(1 To iNumChunks * pChunking) As Variant
+End Sub
+
+
+'Sort the array
+'@param {stdICallable<(variant)=>variant>} A mapping function which should map whatever the input is to whatever variant the array should be sorted on.
+'@param {stdICallable<(variant,variant)=>boolean>} Comparrison function which consumes 2 variants and generates a boolean. See implementation of `Sort_QuickSort` for details.
+'@param {long}    Currently only 1 algorithm: 0 - Quicksort
+'@param {boolean} Sort the array in place. Sorting in-place is prefferred if possible as it is much more performant.
+'@returns {stdArray<T>}
+Public Function Sort(Optional ByVal cbSortBy As stdICallable = Nothing, Optional ByVal cbComparrason As stdICallable = Nothing, Optional ByVal iAlgorithm As Long = 0, Optional ByVal bSortInPlace As Boolean = False) As stdArray
+    If Not bSortInPlace Then
+        Set Sort = Clone().Sort(cbSortBy, cbComparrason, iAlgorithm, True)
+    Else
+        If Length() = 0 Then
+          Set Sort = Me
+          Exit Function
+        End If
+
+        Dim arr() As SortStruct
+        ReDim arr(1 To Length()) As SortStruct
+
+        Dim i As Long
+
+        'Copy array to sort structures
+        For i = 1 To Length()
+            Call CopyVariant(arr(i).value, pArr(i))
+            If cbSortBy Is Nothing Then
+                Call CopyVariant(arr(i).sortValue, pArr(i))
+            Else
+                Call CopyVariant(arr(i).sortValue, cbSortBy.Run(pArr(i)))
+            End If
+        Next
+
+        'Call sort algorithm
+        Select Case iAlgorithm
+            Case 0 'QuickSort
+                Call Sort_QuickSort(arr, cbComparrason)
+            Case Else
+                stdError.Raise "Invalid sorting algorithm specified"
+        End Select
+
+        'Copy sort structures to array
+        For i = 1 To Length()
+            Call CopyVariant(pArr(i), arr(i).value)
+        Next
+
+        'Return array
+        Set Sort = Me
+    End If
+End Function
+
+'QuickSort3
+' Src: https://www.vbforums.com/showthread.php?473677-VB6-Sorting-algorithms-%28sort-array-sorting-arrays%29
+' Omit plngLeft & plngRight; they are used internally during recursion
+Private Sub Sort_QuickSort(ByRef pvarArray() As SortStruct, Optional cbComparrison As stdICallable = Nothing, Optional ByVal plngLeft As Long, Optional ByVal plngRight As Long)
+    Dim lngFirst As Long
+    Dim lngLast As Long
+    Dim varMid As SortStruct
+    Dim varSwap As SortStruct
+
+    If plngRight = 0 Then
+        plngLeft = 1
+        plngRight = Length()
+    End If
+    lngFirst = plngLeft
+    lngLast = plngRight
+    varMid = pvarArray((plngLeft + plngRight) \ 2)
+    Do
+        If cbComparrison Is Nothing Then
+            Do While pvarArray(lngFirst).sortValue < varMid.sortValue And lngFirst < plngRight
+                lngFirst = lngFirst + 1
+            Loop
+            Do While varMid.sortValue < pvarArray(lngLast).sortValue And lngLast > plngLeft
+                lngLast = lngLast - 1
+            Loop
+        Else
+            Do While cbComparrison.Run(pvarArray(lngFirst).sortValue, varMid.sortValue) And lngFirst < plngRight
+                lngFirst = lngFirst + 1
+            Loop
+            Do While cbComparrison.Run(varMid.sortValue, pvarArray(lngLast).sortValue) And lngLast > plngLeft
+                lngLast = lngLast - 1
+            Loop
+        End If
+
+        If lngFirst <= lngLast Then
+            varSwap = pvarArray(lngFirst)
+            pvarArray(lngFirst) = pvarArray(lngLast)
+            pvarArray(lngLast) = varSwap
+            lngFirst = lngFirst + 1
+            lngLast = lngLast - 1
+        End If
+    Loop Until lngFirst > lngLast
+    If plngLeft < lngLast Then Sort_QuickSort pvarArray, cbComparrison, plngLeft, lngLast
+    If lngFirst < plngRight Then Sort_QuickSort pvarArray, cbComparrison, lngFirst, plngRight
+End Sub
+
+
+
+
+'Obtain the array as a regular VBA array
+Public Property Get arr() As Variant
+    If pLength = 0 Then
+      arr = Array()
+    Else
+      Dim vRet() As Variant
+      ReDim vRet(1 To pLength) As Variant
+      For i = 1 To pLength
+        Call CopyVariant(vRet(i), pArr(i))
+      Next
+      arr = vRet
+    End If
+End Property
+Public Property Let arr(v As Variant)
+    RaiseEvent BeforeArrLet(Me, v)
+    Dim lb As Long: lb = LBound(v)
+    Dim ub As Long: ub = UBound(v)
+    Dim cnt As Long: cnt = ub - lb + 1
+    ReDim pArr(1 To (Int(cnt / pChunking) + 1) * pChunking) As Variant
+    For i = lb To ub
+        Call Push(pArr(i))
+    Next
+    RaiseEvent AfterArrLet(Me, v)
+End Property
+
+'Add an element to the end of the array
+'@param {variant} The element to add to the end of the array.
+'@returns {stdArray} me
+'TODO: Add multiple elements with push
+Public Function Push(ByVal el As Variant) As stdArray
+  If pInitialised Then
+    'Before Add event
+    Dim bCancel As Boolean
+    RaiseEvent BeforeAdd(Me, pLength + 1, el, bCancel)
+    If bCancel Then Exit Function
+
+    If pLength = pProxyLength Then
+        pProxyLength = pProxyLength + pChunking
+        ReDim Preserve pArr(1 To pProxyLength) As Variant
+    End If
+    
+    pLength = pLength + 1
+    CopyVariant pArr(pLength), el
+
+    'After add event
+    RaiseEvent AfterAdd(Me, pLength, pArr(pLength))
+
+    Set Push = Me
+  Else
+    'Error
+  End If
+End Function
+
+'Remove an element from the end of the array
+'@returns {variant} The element removed from the array
+Public Function Pop() As Variant
+    If pInitialised Then
+        If pLength > 0 Then
+            'Raise BeforeRemove event and optionally cancel
+            Dim bCancel As Boolean
+            RaiseEvent BeforeRemove(Me, pLength, pArr(pLength), bCancel)
+            If bCancel Then Exit Function
+
+            CopyVariant Pop, pArr(pLength)
+            pLength = pLength - 1
+
+            'Raise AfterRemove event
+            RaiseEvent AfterRemove(Me, pLength)
+        Else
+            Pop = Empty
+        End If
+    Else
+        'Error
+    End If
+End Function
+
+'Remove the ith element from the array
+'@param {Long} Index of the element to remove
+'@returns {Variant} The element removed
+Public Function Remove(ByVal index As Long) As Variant
+  'Ensure initialised
+  If pInitialised Then
+    'Ensure length > 0
+    If pLength > 0 Then
+      'Ensure index < length
+      If index <= pLength Then
+        'Raise BeforeRemove event and optionally cancel
+        Dim bCancel As Boolean
+        RaiseEvent BeforeRemove(Me, index, pArr(index), bCancel)
+        If bCancel Then Exit Function
+
+        'Copy party we are removing to return variable
+        CopyVariant Remove, pArr(index)
+        
+        'Loop through array from removal, set i-1th element to ith element
+        Dim i As Long
+        For i = index + 1 To pLength
+            pArr(i - 1) = pArr(i)
+        Next
+
+        'Set last element length and subtract total length by 1
+        pArr(pLength) = Empty
+        pLength = pLength - 1
+
+        'Raise after remove event
+        RaiseEvent AfterRemove(Me, index)
+      Else
+        'Error
+      End If
+    Else
+      'Error
+    End If
+  Else
+      'Error
+  End If
+End Function
+
+'Remove and return element from the start of the array
+'@returns {variant} Element removed
+Public Function Shift() As Variant
+  'Would be good to use CopyMemory here
+  
+  CopyVariant Shift, pArr(1)
+  Dim i As Long
+  For i = 1 To pLength - 1
+    pArr(i) = pArr(i + 1)
+  Next
+  pLength = pLength - 1
+End Function
+
+'Insert an element onto the start of the array
+'@param {Variant} Value to append to the start of the array
+'@returns {stdArray} me
+Public Function Unshift(val As Variant) As stdArray
+  'Would be good to use CopyMemory here
+  
+  'Before Add event
+  Dim bCancel As Boolean
+  RaiseEvent BeforeAdd(Me, 1, val, bCancel)
+  If bCancel Then Exit Function
+
+  'Ensure array is big enough and increase pLength
+  If pLength = pProxyLength Then
+    pProxyLength = pProxyLength + pChunking
+    ReDim Preserve pArr(1 To pProxyLength) As Variant
+  End If
+  pLength = pLength + 1
+  
+  'Unshift
+  For i = pLength - 1 To 1 Step -1
+    pArr(i + 1) = pArr(i)
+  Next
+  pArr(1) = val
+  
+  'After Add event
+  RaiseEvent AfterAdd(Me, 1, val)
+
+  Set Unshift = Me
+End Function
+
+'TODO:
+'Public Function Slice() As stdArray
+'
+'End Function
+
+'TODO:
+'Public Function Splice() As stdArray
+'
+'End Function
+
+'Creates a new instance of the same array
+'@returns {stdArray}
+Public Function Clone() As stdArray
+  If pInitialised Then
+      If pInitialised Then
+        'Similar to CreateFromArray() but passing length through also:
+        Set Clone = New stdArray
+        
+        Call Clone.Init(pLength, 10)
+        
+        Dim i As Long
+        For i = 1 To pLength
+            Call Clone.Push(pArr(i))
+        Next
+      Else
+        'Error
+      End If
+
+      RaiseEvent AfterClone(Clone)
+  Else
+    'Error
+  End If
+End Function
+
+'Returns a new array with all elements in reverse order
+'@returns {stdArray}
+Public Function Reverse() As stdArray
+    'TODO: Need to find a better more low level approach to creating arrays from existing arrays/preventing redim for methods like this
+    Dim ret As stdArray
+    Set ret = stdArray.Create()
+    For i = pLength To 1 Step -1
+      Call ret.Push(pArr(i))
+    Next
+    Set Reverse = ret
+End Function
+
+'Concatenate an existing array of elements onto the end of this array
+'@param {stdArray} Array whose elements we wish to append to the end of this array
+'@returns {stdArray} New composite array.
+Public Function Concat(ByVal arr As stdArray) As stdArray
+  Dim x As stdArray
+  Set x = Clone()
+  
+  If Not arr Is Nothing Then
+    Dim i As Long
+    For i = 1 To arr.Length
+      Call x.Push(arr.item(i))
+    Next
+  End If
+  
+  Set Concat = x
+End Function
+
+'Join each of the elements of this array together as a string
+'@param {string} Delimiter to insert between strings
+Public Function Join(Optional ByVal delimeter As String = ",") As String
+  If pInitialised Then
+      If pLength > 0 Then
+        Dim sOutput As String
+        sOutput = pArr(1)
+        
+        Dim i As Long
+        For i = 2 To pLength
+          sOutput = sOutput & delimeter & pArr(i)
+        Next
+        Join = sOutput
+      Else
+        Join = ""
+      End If
+  Else
+    'Error
+  End If
+End Function
+
+'Get/Let/Set item
+'@param {long} The location to get/set the item
+Public Property Get item(ByVal i As Long) As Variant
+    'item(1) = 1st element
+    'item(2) = 2nd element
+    'etc.
+    CopyVariant item, pArr(i)
+    
+End Property
+Public Property Set item(ByVal i As Long, ByVal item As Object)
+  Set pArr(i) = item
+End Property
+Public Property Let item(ByVal i As Long, ByVal item As Variant)
+  pArr(i) = item
+End Property
+
+'Copy a variant into the array's ith element. This saves from having to test the item and call the correct `set` keyword
+'@param {Long} The index at which the item's data should be set
+'@param {ByRef Variant} Item to set at the index
+Public Sub PutItem(ByVal i As Long, ByRef item As Variant)
+  CopyVariant pArr(i), item
+End Sub
+
+'Obtain the index of an element
+'@param {Variant} Element to find
+'@param {Ingeger?=1} Location to start search for element.
+'@returns {long} Index of element
+Public Function indexOf(ByVal el As Variant, Optional ByVal start As Long = 1) As Long
+  Dim elIsObj As Boolean, i As Long, item As Variant, itemIsObj As Boolean
+  
+  'Is element an object?
+  elIsObj = isObject(el)
+  
+  'Loop over contents starting from start
+  For i = start To pLength
+    'Get item data
+    CopyVariant item, pArr(i)
+    
+    'Is item an object?
+    itemIsObj = isObject(item)
+    
+    'If both item and el are objects     (must be the same type in order to be the same data)
+    If itemIsObj And elIsObj Then
+      If item Is el Then 'check items equal
+        indexOf = i 'return item index
+        Exit Function
+      End If
+    'If both item and el are not objects (must be the same type in order to be the same data)
+    ElseIf Not itemIsObj And Not elIsObj Then
+      If item = el Then 'check items equal
+        indexOf = i 'return item index
+        Exit Function
+      End If
+    End If
+  Next
+
+  'Return -1 i.e. no match found
+  indexOf = -1
+End Function
+
+'Obtain the last index of an element
+'@param {Variant} Element to find
+'@returns {long} Last index of element
+Public Function lastIndexOf(ByVal el As Variant)
+  Dim elIsObj As Boolean, i As Long, item As Variant, itemIsObj As Boolean
+  
+  'Is element an object?
+  elIsObj = isObject(el)
+  
+  'Loop over contents starting from start
+  For i = pLength To 1 Step -1
+    'Get item data
+    CopyVariant item, pArr(i)
+    
+    'Is item an object?
+    itemIsObj = isObject(item)
+    
+    'If both item and el are objects     (must be the same type in order to be the same data)
+    If itemIsObj And elIsObj Then
+      If item Is el Then 'check items equal
+        lastIndexOf = i 'return item index
+        Exit Function
+      End If
+    'If both item and el are not objects (must be the same type in order to be the same data)
+    ElseIf Not itemIsObj And Not elIsObj Then
+      If item = el Then 'check items equal
+        lastIndexOf = i 'return item index
+        Exit Function
+      End If
+    End If
+  Next
+
+  'Return -1 i.e. no match found
+  lastIndexOf = -1
+End Function
+
+'Returns true if the array contains an item
+'@param {Variant} Item to find
+'@param {long?=1} Index to start search for item at. (Internally uses indexOf())
+Public Function includes(ByVal el As Variant, Optional ByVal startFrom As Long = 1) As Boolean
+  includes = indexOf(el, startFrom) >= startFrom
+End Function
+
+
+
+
+
+'Iterative Functions (All require stdICallable):
+
+'Example: if incidents.IsEvery(cbValid) then ...
+Public Function IsEvery(ByVal cb As stdICallable) As Boolean
+  If pInitialised Then
+    Dim i As Long
+    For i = 1 To pLength
+      Dim bFlag As Boolean
+      bFlag = cb.Run(pArr(i))
+      
+      If Not bFlag Then
+        IsEvery = False
+        Exit Function
+      End If
+    Next
+    
+    IsEvery = True
+  Else
+    'Error
+  End If
+End Function
+
+Public Function IsSome(ByVal cb As stdICallable) As Boolean
+  If pInitialised Then
+    Dim i As Long
+    For i = 1 To pLength
+      Dim bFlag As Boolean
+      bFlag = cb.Run(pArr(i))
+      
+      If bFlag Then
+        IsSome = True
+        Exit Function
+      End If
+    Next
+    IsSome = False
+  Else
+    'Error
+  End If
+End Function
+
+Public Sub ForEach(ByVal cb As stdICallable)
+  If pInitialised Then
+    Dim i As Long
+    For i = 1 To pLength
+      Call cb.Run(pArr(i))
+    Next
+  Else
+    'Error
+  End If
+End Sub
+
+Public Function Map(ByVal cb As stdICallable) As stdArray
+  If pInitialised Then
+    Dim pMap As stdArray
+    Set pMap = Clone()
+    
+    Dim i As Long
+    For i = 1 To pLength
+      'BUGFIX: Sometimes required, not sure when
+      Dim v As Variant
+      CopyVariant v, item(i)
+      
+      'Call callback
+      Call pMap.PutItem(i, cb.Run(v))
+    Next
+    
+    Set Map = pMap
+  Else
+    'Error
+  End If
+End Function
+
+
+'OPTIMISE: Needs optimisation. Currently very sub-optimal
+Public Function Unique(Optional ByVal cb As stdICallable = Nothing) As stdArray
+  Dim ret As stdArray: Set ret = stdArray.CreateWithOptions(pLength, pChunking)
+  Dim retL As stdArray: Set retL = CreateWithOptions(pLength, pChunking)
+  
+  'Collect keys
+  Dim vKeys As stdArray
+  If cb Is Nothing Then
+    Set vKeys = Clone()
+  Else
+    Set vKeys = Map(cb)
+  End If
+  
+  'Unique by key
+  For i = 1 To pLength
+    If Not retL.includes(vKeys.item(i)) Then
+      Call retL.Push(vKeys.item(i))
+      Call ret.Push(pArr(i))
+    End If
+  Next
+
+  'Return data
+  Set Unique = ret
+End Function
+
+Public Function reduce(ByVal cb As stdICallable, Optional ByVal initialValue As Variant) As Variant
+  Dim iStart As Long
+  If pInitialised Then
+    If pLength > 0 Then
+      If IsMissing(initialValue) Then
+        Call CopyVariant(reduce, pArr(1))
+        iStart = 2
+      Else
+        Call CopyVariant(reduce, initialValue)
+        iStart = 1
+      End If
+    Else
+      If IsMissing(initialValue) Then
+        reduce = Empty
+      Else
+        Call CopyVariant(reduce, initialValue)
+      End If
+      Exit Function
+    End If
+    
+    Dim i As Long
+    For i = iStart To pLength
+      'BUGFIX: Sometimes required, not sure when
+      Dim el As Variant
+      CopyVariant el, pArr(i)
+
+      'Reduce
+      CopyVariant reduce, cb.Run(reduce, el)
+    Next
+  Else
+    'Error
+  End If
+End Function
+
+
+Public Function Filter(ByVal cb As stdICallable) As stdArray
+    Dim ret As stdArray
+    Set ret = stdArray.CreateWithOptions(pLength, pChunking)
+    Set Filter = ret
+
+    'If initialised...
+    If pInitialised Then
+        Dim i As Long, v As Variant
+        'Loop over array
+        For i = 1 To pLength
+            'If callback succeeds, push retvar
+            If cb.Run(pArr(i)) Then
+                Call ret.Push(pArr(i))
+            End If
+        Next i
+    Else
+        'error
+    End If
+End Function
+
+Public Function count(Optional ByVal cb As stdICallable = Nothing) As Long
+  If cb Is Nothing Then
+    count = Length
+  Else
+    Dim i As Long, lCount As Long
+    lCount = 0
+    For i = 1 To pLength
+      If cb.Run(pArr(i)) Then
+        lCount = lCount + 1
+      End If
+    Next i
+    count = lCount
+  End If
+End Function
+
+Public Function groupBy(ByVal cb As stdICallable) As Object
+    'Array to store result in
+    Dim result As Object
+    Set result = CreateObject("Scripting.Dictionary")
+
+    'Loop over items
+    Dim i As Long
+    For i = 1 To pLength
+        'Get grouping key
+        Dim key As Variant
+        key = cb.Run(pArr(i))
+
+        'If key is not set then set it
+        If Not result.Exists(key) Then Set result(key) = stdArray.Create()
+
+        'Push item to key
+        result(key).Push pArr(i)
+    Next
+
+    'Return result
+    Set groupBy = result
+End Function
+
+Public Function Max(Optional ByVal cb As stdICallable = Nothing, Optional ByVal startingValue As Variant = Empty) As Variant
+  Dim vRet, vMaxValue, v
+  vMaxValue = startingValue: vRet = startingValue
+  For i = 1 To pLength
+    Call CopyVariant(v, pArr(i))
+    
+    'Get value to test
+    Dim vtValue As Variant
+    If cb Is Nothing Then
+      Call CopyVariant(vtValue, v)
+    Else
+      Call CopyVariant(vtValue, cb.Run(v))
+    End If
+
+    'Compare values and return
+    If IsEmpty(vRet) Then
+      Call CopyVariant(vRet, v)
+      Call CopyVariant(vMaxValue, vtValue)
+    ElseIf vMaxValue < vtValue Then
+      Call CopyVariant(vRet, v)
+      Call CopyVariant(vMaxValue, vtValue)
+    End If
+  Next
+
+  Call CopyVariant(Max, vRet)
+End Function
+Public Function Min(Optional ByVal cb As stdICallable = Nothing, Optional ByVal startingValue As Variant = Empty) As Variant
+  Dim vRet, vMinValue, v
+  vMinValue = startingValue: vRet = startingValue
+  For i = 1 To pLength
+    Call CopyVariant(v, pArr(i))
+    
+    'Get value to test
+    Dim vtValue As Variant
+    If cb Is Nothing Then
+      Call CopyVariant(vtValue, v)
+    Else
+      Call CopyVariant(vtValue, cb.Run(v))
+    End If
+
+    'Compare values and return
+    If IsEmpty(vRet) Then
+      Call CopyVariant(vRet, v)
+      Call CopyVariant(vMinValue, vtValue)
+    ElseIf vMinValue > vtValue Then
+      Call CopyVariant(vRet, v)
+      Call CopyVariant(vMinValue, vtValue)
+    End If
+  Next
+
+  Call CopyVariant(Min, vRet)
+End Function
+
+'Copies one variant to a destination
+'@param {ByRef Variant} dest Destination to copy variant to
+'@param {Variant} value Source to copy variant from.
+'@perf This appears to be a faster variant of "oleaut32.dll\VariantCopy" + it's multi-platform
+Private Sub CopyVariant(ByRef dest As Variant, ByVal value As Variant)
+  If isObject(value) Then
+    Set dest = value
+  Else
+    dest = value
+  End If
+End Sub

CodeStore/index.xlsm_stdICallable.bas

@@ -0,0 +1,34 @@
+Attribute VB_Name = "stdICallable"
+
+'Call will call the passed function with param array
+Public Function Run(ParamArray params() As Variant) As Variant: End Function
+
+'Call function with supplied array of params
+Public Function RunEx(ByVal params As Variant) As Variant: End Function
+
+'Bind a parameter to the function
+Public Function Bind(ParamArray params() As Variant) As stdICallable: End Function
+
+'Making late-bound calls to stdICallable members
+'@protected
+'@param {ByVal String} - Message to send
+'@param {ByRef Boolean} - Whether the call was successful
+'@param {ByVal Variant} - Any variant, typically parameters as an array. Passed along with the message.
+'@returns {Variant} - Any return value.
+Public Function SendMessage(ByVal sMessage As String, ByRef success As Boolean, ByVal params As Variant) As Variant: End Function
+
+'Ideally we would want to get a pointer to the function... However, getting a pointer to an object method is
+'going to be defficult, partly due to the first parameter sent to the function is `Me`! We'll likely have to
+'use machine code to wrap a call with a `Me` pointer just so we can access the full pointer and use this in
+'real life applications.
+'Finally it might be better to do something more like: `stdPointer.fromICallable()` anyway
+  ''Returns a callback function
+  ''Typically this will be achieved with `stdPointer.GetLastPrivateMethod(me)`
+  ''If this cannot be implemented return 0
+  'Public Function ToPointer() as long
+
+''Bind arguments to functions to appear as first arguments in call.
+''e.g. stdLambda.Create("$1.EnableEvents = false: $1.ScreenUpdating = false").bind(Application).Run()
+'Public Function Bind(ByVal v as variant) as stdICallable: End Function
+
+

CodeStore/index.xlsm_工作表1.bas

@@ -0,0 +1,56 @@
+Attribute VB_Name = "工作表1"
+Private Sub CommandButton21_Click()
+'    Application.Caption = PYEAR & Worksheets("售價").Cells(3, 1)
+    Dim oSB As Object
+    Set oSB = CreateObject("System.Text.StringBuilder")
+    
+    oSB.AppendFormat_5 Nothing, "hello {0}", Array("simon")
+    Debug.Assert oSB.ToString = "hello simon"
+
+End Sub
+
+'Private Sub sample()
+'  Dim exl As Excel.Application
+'  Dim wb As Excel.Workbook
+'  Dim i As Integer
+'  Dim j As Integer
+'  Dim cnt As Integer
+'  Dim cn As New ADODB.Connection
+'  Dim t1 As Date
+'  Dim t2 As Date
+'  Dim t As Date
+'
+'  t1 = Now
+'
+'  Set exl = CreateObject("Excel.Application")
+'  Set wb = exl.Workbooks.Add
+'
+'  exl.ActiveWorkbook.SaveAs (Excel.ThisWorkbook.Path & "\sample3.xls")
+'  exl.ActiveWorkbook.Close
+'  exl.Quit
+'
+'  cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
+'          "Data Source=" & Excel.ThisWorkbook.Path & "\sample3.xls;" & _
+'          "Extended Properties=""Excel 8.0;HDR=YES;IMEX=0"""
+'
+'  cn.Execute "CREATE TABLE [工作表1$] (R INT, G INT, B INT)"
+'  cn.Execute "UPDATE [工作表1$] SET R = 0"
+'  cn.Execute "UPDATE [工作表1$] SET G = 1"
+'  cn.Execute "UPDATE [工作表1$] SET B = 2"
+'
+'  cnt = 3
+'  For i = 1 To 10000
+'    cn.Execute "INSERT INTO [工作表1$] (R,G,B) VALUES (" & cnt & "," & cnt + 1 & "," & cnt + 2 & ")"
+'    cnt = cnt + 3
+'  Next i
+'
+'  cn.Close
+'  Set cn = Nothing
+'  t2 = Now
+'
+'  t = t2 - t1
+'
+'  MsgBox Second(t)
+'End Sub
+
+

CodeStore/index.xlsm_工作表10.bas

@@ -0,0 +1,78 @@
+Attribute VB_Name = "工作表10"
+'**************** 程式變數 ******************
+Const PYEAR = 2023
+Const PCOMPANY = 27
+Const strXLSfile = "\index.xlsb" '資料來源
+Const intFieldAmount = 20                           '表中欄位數目
+Const ITEMcount = 9                                '處理品項數目
+Const MSC = 5                                       '男生班級行數
+Const MSD = 7                                       '男生小計行數
+Const WSC = 13                                      '女生班級行數
+Const WSD = 15                                      '女生小計行數
+'********************************************
+
+Private Sub Worksheet_Activate()
+Dim p As Long
+Dim diag As New ProgressDialogue
+Application.Calculation = xlManual      '設置手動重算
+p = 0
+diag.Configure "更新資料時間", "Now wasting your time...", 0, ITEMcount
+diag.Show
+    For i = 1 To ITEMcount
+        Call subtotal(i, 1, 3)
+        Call subtotal(i, 2, 3)
+diag.SetValue p
+diag.SetStatus "Now wasting your time... " & p
+p = p + 1
+    Next i
+diag.Hide
+Application.Calculation = xlAutomatic   '設置自動重算
+
+End Sub
+
+Public Sub subtotal(strField As Variant, intRange As Variant, intRow As Variant)
+' strField      小計使用欄位
+' intRange  男、女      1,2
+' intRow        填入列數
+Dim rstSubtotal As ADODB.Recordset
+Dim strSQL As String
+Dim intRowLoc As Integer
+Dim fldClass, fldAmount As Field
+Dim cellClass, cellData As Range
+
+Dim Cnmy As ADODB.Connection
+Set Cnmy = Cnmyopen()
+Set rstSubtotal = New ADODB.Recordset
+    strSQL = "SELECT departclass, sum(item" & strField & ") " & _
+                    "FROM clothing.BUYANDSELL " & _
+                    "where departclass<>'0' and " & Choose(intRange, "cus_sex=true and ", "cus_sex=false and ", "") & _
+                    "sid between " & PYEAR & PCOMPANY & "0000 AND " & PYEAR & PCOMPANY & "9999" & _
+                    " group by department;"
+'    Debug.Print strSQL
+'    rstSubtotal.CursorLocation = 3         'mysql RecordCount連線BUG by 藍色小舖 老頑童
+    rstSubtotal.Open strSQL, Cnmy
+
+Set fldClass = rstSubtotal.Fields(0)                                                                            '項目尺寸
+Set fldAmount = rstSubtotal.Fields(1)                                                                           '項目尺寸數量
+    For intI = 1 To intFieldAmount                                                                              '行填入位置
+Set cellClass = Range(Cells(intRow + (strField - 1) * 21 + intI - 1, IIf(intRange = 1, MSC, WSC)), _
+                Cells(intRow + (strField - 1) * 21 + intI - 1, IIf(intRange = 1, MSC, WSC)))        '欄位名稱
+Set cellData = Range(Cells(intRow + (strField - 1) * 21 + intI - 1, IIf(intRange = 1, MSD, WSD)), _
+                Cells(intRow + (strField - 1) * 21 + intI - 1, IIf(intRange = 1, MSD, WSD)))        '欄位資料
+      If Not rstSubtotal.EOF Then
+        cellClass.value = fldClass
+        cellData.value = fldAmount
+        rstSubtotal.MoveNext
+      Else
+        '清除項目內容
+        cellClass.ClearContents
+        cellData.ClearContents
+      End If
+    Next intI
+    
+    rstSubtotal.Close
+    Set rstSubtotal = Nothing
+
+End Sub
+
+

CodeStore/index.xlsm_工作表11.bas

@@ -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
+

CodeStore/index.xlsm_工作表14.bas

@@ -0,0 +1,71 @@
+Attribute VB_Name = "工作表14"
+Private Sub Worksheet_Activate()
+    Dim startTime As Double, totalRows As Long
+    Dim dict As Object
+    Dim itemAddup As New stdArray
+    Dim changeRange As Variant
+    Dim tmp As stdArray
+    Dim oArr As Variant, pArr As Variant, qArr As Variant
+    Dim i As Long, arrWords As Variant
+    Dim key As Variant, vIter As Variant
+    
+    ' 創建字典
+    Set dict = CreateObject("Scripting.Dictionary")
+
+    ' 設置範圍
+    changeRange = Me.Range("ChangeTBL").Resize(100)
+    
+    ' 開始計時
+    startTime = Timer
+    
+    ' 填充字典
+    For i = 1 To UBound(changeRange)
+        If Not IsEmpty(changeRange(i, 1)) Then
+            Call FillDictionary(dict, changeRange(i, 1) & "_" & changeRange(i, 2), changeRange(i, 3))
+        End If
+    Next i
+    
+    ' 將字典中的項目添加到 itemAddup
+    Set itemAddup = stdArray.Create
+    For Each key In dict.keys
+        itemAddup.Push key & "_" & dict(key)
+    Next key
+    totalRows = dict.count
+    
+    ' 初始化輸出範圍的數組
+    Me.Range("O3").CurrentRegion.ClearContents
+    oArr = Me.Range("O3").Resize(totalRows)
+    pArr = Me.Range("P3").Resize(totalRows)
+    qArr = Me.Range("Q3").Resize(totalRows)
+    
+    ' 排序並將值填充到臨時數組
+    Set tmp = stdArray.Create
+    itemAddup.Sort().ForEach stdLambda.Create("$1.push($2)").Bind(tmp)
+    
+    ' 迭代臨時數組並將值填充到相應的欄位
+    i = 1
+    For Each vIter In tmp
+        arrWords = Split(vIter, "_")
+        oArr(i, 1) = arrWords(0)
+        pArr(i, 1) = arrWords(1)
+        qArr(i, 1) = arrWords(2)
+        i = i + 1
+    Next vIter
+    
+    ' 顯示執行時間
+    Me.Range("O1").value = Timer - startTime
+
+    ' 將結果寫回工作表
+    Me.Range("O3").Resize(totalRows).value = oArr
+    Me.Range("P3").Resize(totalRows).value = pArr
+    Me.Range("Q3").Resize(totalRows).value = qArr
+End Sub
+
+Private Sub FillDictionary(ByRef dict As Object, item As Variant, itemValue As Variant)
+    If dict.Exists(item) Then
+        dict(item) = dict(item) + itemValue
+    Else
+        dict.Add item, itemValue
+    End If
+End Sub
+

CodeStore/index.xlsm_工作表15.bas

@@ -0,0 +1,2 @@
+Attribute VB_Name = "工作表15"
+

CodeStore/index.xlsm_工作表2.bas

@@ -0,0 +1,2 @@
+Attribute VB_Name = "工作表2"
+

CodeStore/index.xlsm_工作表3.bas

@@ -0,0 +1,2 @@
+Attribute VB_Name = "工作表3"
+

CodeStore/index.xlsm_工作表4.bas

@@ -0,0 +1,99 @@
+Attribute VB_Name = "工作表4"
+'**************** 程式變數 **********************
+Const PYEAR = 2024                      '年度
+Const PCOMPANY = 27
+Const strXLSfile = "\index.xlsb"         '資料來源
+'************************************************
+
+Private Sub CommandButton21_Click()
+Dim strSQL As String
+On Error GoTo Err_cmdYes_Click
+
+' 匯入資料
+    Call updSELLUP
+    
+Exit_cmdYes_Click:
+    Exit Sub
+
+Err_cmdYes_Click:
+    MsgBox Err.Description
+    Resume Exit_cmdYes_Click
+
+End Sub
+
+' 匯入量身資料
+Public Sub updSELLUP()
+'====================================+
+Dim p As Long                       '|
+Dim diag As New ProgressDialogue    '|
+'====================================+
+Dim sb As StringBuilder
+Set sb = New StringBuilder
+Dim rstItem As New ADODB.Recordset
+Dim rstTBL As New ADODB.Recordset               'excel資料表
+Dim strSQL, strSQLitem As String
+Dim fld As ADODB.Field
+Dim Cnxn, Cnmy As ADODB.Connection
+Set Cnmy = Cnmyopen()
+Set Cnxn = Cnxnopen(XLSfile, "1")
+    
+    sb.Append "Select " & PYEAR & PCOMPANY & " & Format([編號],'0000') AS ID,[班ID] as depart,[性別] as sex" & _
+        ", [校短尺碼] as itsz1, [校短訂購] as item1, [校長尺碼] as itsz2, [校長訂購] as item2, [校夏尺碼] as itsz3, [校夏訂購] as item3" & _
+        ", [校冬尺碼] as itsz4, [校冬訂購] as item4, [校裙尺碼] as itsz5, [校裙訂購] as item5" & _
+        ", [背心尺碼] as itsz6, [背心訂購] as item6, 0 as itsz7, [書包訂購] as item7, 0 as itsz8, [領帶訂購] as item8, 0 as itsz9, [腰帶訂購] as item9" & _
+        " FROM [帳務$];"
+' Debug.Print sb.toString
+With rstTBL
+    .Open sb.ToString, Cnxn, adOpenStatic, adLockOptimistic, adCmdText
+    lastdepart = !depart
+'====================================================================================+
+p = 0                                                                               '|
+diag.Configure "更新資料時間", "Now wasting your time...", 0, .RecordCount          '|
+diag.Show                                                                           '|
+'====================================================================================+
+    strSQLitem = "SELECT pno,mtmodel,mtname,mtcolor,wtmodel,wtname,wtcolor,tomeasure FROM GoodsUse" & _
+            " WHERE corp_use=" & PCOMPANY & " and Depart_Use=" & !depart & _
+            " order by pno;"
+    rstItem.Open strSQLitem, Cnmy
+    While Not (.EOF Or diag.cancelIsPressed)
+        If Not lastdepart = !depart Then
+            rstItem.Close
+            strSQLitem = "SELECT pno,mtmodel,mtname,mtcolor,wtmodel,wtname,wtcolor,tomeasure FROM GoodsUse" & _
+                    " WHERE corp_use=" & PCOMPANY & " and Depart_Use=" & !depart & _
+                    " order by pno;"
+            rstItem.Open strSQLitem, Cnmy
+'    Range("AF3").CopyFromRecordset rstItem
+        End If
+        i = 1
+        rstItem.MoveFirst
+        sb.Clear
+        sb.Append "UPDATE SELLUP SET "
+        '資料來源動態設定
+        While Not rstItem.EOF
+            sb.Append "itsz" & i & "=goodsid('" & .Fields.item("itsz" & i) & "'," & IIf(!sex = "男", rstItem!mtmodel, rstItem!wtmodel) & ")," & _
+                "item" & i & "=" & .Fields.item("item" & i)
+            i = i + 1
+            rstItem.MoveNext
+            If Not rstItem.EOF Then sb.Append ","
+        Wend
+        sb.Append " WHERE id=" & !ID & ";"
+Debug.Print sb.ToString
+        ' Cnmy.Execute sb.toString
+        lastdepart = !depart
+        .MoveNext
+'================================================+
+diag.SetValue p                                 '|
+diag.SetStatus "Now wasting your time... " & p  '|
+p = p + 1                                       '|
+'================================================+
+    Wend
+'============+
+diag.Hide   '|
+'============+
+    .Close
+End With
+    Cnxn.Close
+
+End Sub
+
+

CodeStore/index.xlsm_工作表5.bas

@@ -0,0 +1,2 @@
+Attribute VB_Name = "工作表5"
+

CodeStore/index.xlsm_工作表6.bas

@@ -0,0 +1,2 @@
+Attribute VB_Name = "工作表6"
+

CodeStore/index.xlsm_工作表7.bas

@@ -0,0 +1,83 @@
+Attribute VB_Name = "工作表7"
+'**************** 程式變數 ******************
+Const strXLSfile = "\index.xlsm"             '資料來源
+Const idxStart = 1810
+Const idxEnd = 1849
+Const idxRange = "argRange"
+'********************************************
+
+Private Sub CommandButton1_Click()
+Dim sb As StringBuilder
+Set sb = New StringBuilder
+
+Dim strSQL As String
+On Error GoTo Err_cmdYes_Click
+Dim Cnmy As ADODB.Connection
+Set Cnmy = Cnmyopen()
+
+'清除舊資料
+    sb.Append "delete FROM DEPARTMENT where id BETWEEN " & idxStart & " AND " & idxEnd & ";"
+    Cnmy.Execute sb.ToString     '刪除站點
+' 更新資料
+    Call renewDepart(Cnmy)
+    
+Exit_cmdYes_Click:
+    Exit Sub
+
+Err_cmdYes_Click:
+    MsgBox Err.Description
+    Resume Exit_cmdYes_Click
+
+End Sub
+
+Public Sub renewDepart(Cnmy As ADODB.Connection)
+'*************************************
+Dim p As Long                       '*
+Dim diag As New ProgressDialogue    '*
+'*************************************
+' 更新站點資料
+Dim sb As StringBuilder
+Set sb = New StringBuilder
+
+Dim Cnxn As ADODB.Connection
+Dim rstTBL As New ADODB.Recordset
+Dim strSQL As String
+
+Set Cnxn = Cnxnopen(strXLSfile, "1")
+
+    sb.Append "Select 代碼 as id, 科別 as title, 代碼 as depart FROM [引數$" & _
+    Replace(Sheets("引數").Range(idxRange).Address, "$", "") & "];"
+' Debug.Print sb.toString
+    rstTBL.Open sb.ToString, Cnxn, adOpenStatic, adLockOptimistic, adCmdText
+'*************************************************************************************
+p = 0                                                                               '*
+diag.Configure "Wasting Time", "Now wasting your time...", 0, rstTBL.RecordCount    '*
+diag.Show                                                                           '*
+'*************************************************************************************
+    sb.Clear
+    sb.Append "INSERT INTO DEPARTMENT(id,title,depart) VALUES "
+    
+    While Not (rstTBL.EOF Or diag.cancelIsPressed)
+        If Not IsNull(rstTBL.Fields.item("title")) Then
+            sb.Append "(" & rstTBL.Fields.item("id") & ",'"
+            sb.Append rstTBL.Fields.item("title") & "','"
+            sb.Append rstTBL.Fields.item("depart") & "')"
+        End If
+        rstTBL.MoveNext
+        If Not rstTBL.EOF Then
+            sb.Append ","
+        End If
+'*************************************************
+diag.SetValue p                                 '*
+diag.SetStatus "Now wasting your time... " & p  '*
+p = p + 1                                       '*
+'*************************************************
+    Wend
+' Debug.Print sb.toString
+    Cnmy.Execute sb.ToString
+    rstTBL.Close
+'*************
+diag.Hide   '*
+'*************
+End Sub
+

CodeStore/index.xlsm_工作表8.bas

@@ -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
+
+

CodeStore/index.xlsm_工作表9.bas

@@ -0,0 +1,77 @@
+Attribute VB_Name = "工作表9"
+'**************** 程式變數 ******************
+'Const PYEAR = 2020                              '年度
+'Const PCOMPANY = 11                             '公司代碼
+'Const strXLSfile = "\制服.xlsm"                 '資料來源
+'Const strLookup = "中油嘉義"                  '使用程式的學校
+Const ITEMcount = 5                             '匯入處理品項數目
+Const intFieldAmount = 22                       '表中欄位數目
+Const xlsRANGE = "[引數$J1:K23]"              '排序引數表中位置
+Const intFLeft = 23                             '填入表格左邊界
+
+Private Sub CommandButton1_Click()
+Dim strSQL As String
+On Error GoTo Err_cmdYes_Click
+
+Application.Calculation = xlManual '設置手動重算
+'查詢欄位名稱table
+Dim Cnxn As New ADODB.Connection
+Set Cnxn = Cnxnopen(XLSfile, "1")
+
+   Range("W2:AF28").Clear              '清除使用範圍儲存格
+   Call FfName(Cnxn, "校裙", 2)
+'    Call FfName(Cnxn, "短袖", 9)
+'    Call FfName(Cnxn, "長褲", 16)
+'    Call FfName(Cnxn, "夾克", 23)
+'
+Application.Calculation = xlAutomatic ' 設置自動重算
+Cnxn.Close
+Set Cnxn = Nothing
+
+Exit_cmdYes_Click:
+   Exit Sub
+
+Err_cmdYes_Click:
+   MsgBox Err.Description
+   Resume Exit_cmdYes_Click
+
+End Sub
+
+Private Sub FfName(Cnxn As ADODB.Connection, strItem As String, intRow As Integer)
+' intRange  男、女、全      1,2,3
+' intRow    填表行位置
+Dim rstFfname As New ADODB.Recordset
+Dim strSQL As String
+Dim intRowLoc As Integer
+           'select 尺碼,男人數,男數量,女人數,女數量,合計
+   strSQL = "Select " & strItem & "尺碼,sum(IIf(性別='男',1,0))," & "sum(IIf(性別='男'," & strItem & "訂購,0))," & _
+           "sum(IIf(性別='男',0,1)),sum(IIf(性別='男',0," & strItem & "訂購))," & "sum(" & strItem & "訂購)," & xlsRANGE & ".id " & _
+           "FROM [異動$] INNER JOIN " & xlsRANGE & " ON " & xlsRANGE & ".strorder = [異動$]." & strItem & "尺碼" & _
+           " WHERE isnull([異動$].員編)" & _
+           " GROUP BY " & xlsRANGE & ".id,[異動$]." & strItem & "尺碼" & _
+           " ORDER BY " & xlsRANGE & ".id;"
+'    Debug.Print strSQL
+   rstFfname.Open strSQL, Cnxn, adOpenStatic, adLockOptimistic, adCmdText
+   '填入項目
+   For intJ = 1 To WorksheetFunction.RoundUp(rstFfname.RecordCount / intFieldAmount, 0)         '行數目限制
+       intRowLoc = IIf(intJ <> 1, intRow + (2 * (intJ - 1)), intRow)                       'intJ表一範圍
+   For intI = 1 To intFieldAmount
+     If Not rstFfname.EOF Then
+       For intK = 0 To 5                                         '行填入位置
+           Cells(intRowLoc + intK, intFLeft + intI).Borders.LineStyle = xlContinuous
+           Cells(intRowLoc + intK, intFLeft + intI).value = rstFfname.Fields(intK)
+       Next intK
+       rstFfname.MoveNext
+     End If
+   Next intI
+   Next intJ
+rstFfname.Close
+Set rstFfname = Nothing
+
+End Sub
+
+
+
+
+
+