加入 CodeStore VBA 模組

2026-08-18 00:39:40 +08:00
1 parent 9c5364f88e
commit 0e638bdd15
@@ -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
+
+
+
+
+