小程序开发价格 考核汇总表：按遴荐部门司法索取明细数据，动态添加部门下拉列表控件【VBA代码】

发布日期：2024-11-05 05:45    点击次数：51

推行纲领

考核汇总表（ComboBox版）|圆善代码

1、在使命表“发牌考核”内外，号召按钮点击事件、复选框控件Change事件、使命表激活事件，调用相应历程。

Private Sub CmdSum_Click()    Call createList    Call updateEnd SubPrivate Sub ckbDept_Change()    Dim comb As OLEObject    Me.CkbAutoUpdate = False  '//全选再自动更新时，速率慢，取消自动更新    Call createList    If ckbDept.Value = True Then        For i = 2 To deptList.Count + 1            Me.OLEObjects("comb_" & i).Object.Value = deptList.getkey(i - 2)        Next    Else        For i = 2 To deptList.Count + 1            Me.OLEObjects("comb_" & i).Object.Value = ""        Next    End If    Call updateEnd SubPrivate Sub Worksheet_Activate()    Call CreateComboBoxes    Me.ckbDept.Object.Value = TrueEnd Sub

2、在myModule里，CreateComboBoxes历程，动态添加、种植ComboBox控件：

一区（01-12）：上期一区开出3个奖号：05 07 10，最近10期一区开出奖号总数为：20个。本期关注1个一区号码：03。

小程序开发

Public deptList As Object, sKey As StringDim combCollection As CollectionSub CreateComboBoxes()    Dim ws As Worksheet, wsTarget As Worksheet, lastRow As Integer    Dim i As Integer    Dim rng As Range    Dim CmbBox As OLEObject    Dim clsComb As classComboBox    Dim CmbBoxExists As Boolean    Dim arr(), arrtemp()    Call createList        '//添加ComboBox控件    Set ws = ThisWorkbook.Sheets("发牌考核")    Set combCollection = New Collection    With ws        lastRow = deptList.Count + 1        For Each CmbBox In .OLEObjects            With CmbBox                If .Name Like "comb_*" Then                    currRow = CInt(Replace(CmbBox.Name, "comb_", ""))                    If currRow > lastRow Then                        .Visible = False                        .Object.Value = False                    End If                End If            End With        Next        For i = 2 To lastRow            CmbBoxExists = False ' 默许假定不存在            '查验该ComboBox是否如故存在            For Each CmbBox In .OLEObjects                If CmbBox.Name = "comb_" & i Then                    CmbBoxExists = True                    Exit For                End If            Next            Set rng = .Cells(i, "J")            If Not CmbBoxExists Then                '创建ComboBox                Set CmbBox = .OLEObjects.Add(ClassType:="Forms.ComboBox.1", _                    Link:=False, DisplayAsIcon:=False)'                .Rows(i).Interior.Color = xlNone            End If            With CmbBox                .Object.Clear                .Left = rng.Left + 2                .Top = rng.Top + 1                .Height = rng.Height - 2                .Width = rng.Width - 4                .Name = "comb_" & i                .Visible = True                For j = 0 To deptList.Count - 1                    .Object.AddItem deptList.getkey(j)                Next            End With            '创建类实例并麇集事件            Set clsComb = New classComboBox            Set clsComb.CmbBox = CmbBox.Object            combCollection.Add clsComb        Next    End WithEnd Sub

3、在myModule里，update历程，更新明细数据到汇总表，种植单位格法子、控件背首肯等；mergeRange历程，把指定区域统一居中：

Sub update()    Dim ws As Worksheet, rng As Range, lastCol As Integer    Dim arrtemp(), key As Variant    Dim comb As OLEObject, currRow As Integer    Dim ckbBackColor As Double        'On Error Resume Next    Application.DisplayAlerts = False    'Application.ScreenUpdating = False    ckbBackColor = RGB(224, 255, 255)   '背首肯        Set ws = ThisWorkbook.Sheets("发牌考核")    '//先罢休推行，专业小程序开发要多少钱再写入数据    With ws        lastRow = .UsedRange.Rows.Count        lastCol = .UsedRange.Columns.Count        If lastRow > 2 Then            .Range(.Cells(3, 1), .Cells(lastRow, lastCol)).Clear        End If        t = 0        For Each comb In .OLEObjects            currRow = CInt(Val(Replace(comb.Name, "comb_", "")))            If currRow > 1 Then                If comb.Object.Value <> "" Then                    t = 1                    comb.Object.BackColor = ckbBackColor                Else                    comb.Object.BackColor = vbWhite                End If            End If        Next        If t = 0 Then Exit Sub        currRow = 3                For Each comb In .OLEObjects            If comb.Name Like "comb_*" And comb.Object.Value <> "" Then                key = comb.Object.Value                If deptList.contains(key) Then                    If CInt(Val(Replace(comb.Name, "comb_", ""))) > 1 And key <> "" Then                        k = k + 1                        arrtemp = deptList.Item(key)                        .Cells(currRow, 1).Resize(UBound(arrtemp, 2), UBound(arrtemp)) = Application.WorksheetFunction.Transpose(arrtemp)                        .Cells(currRow, 1).Resize(UBound(arrtemp, 2), 1) = k                        currRow = currRow + UBound(arrtemp, 2)                    End If                End If            End If        Next                '//单位格统一居中                For i = 3 To currRow            If .Cells(i, 8) = "自查" Then                .Cells(i, 3).Resize(1, 6).Interior.Color = RGB(255, 250, 205)            End If            If .Cells(i, 1) <> .Cells(i - 1, 1) Then                m = i                Total = 0            End If            If .Cells(i, 1) <> .Cells(i + 1, 1) Then                n = i                For j = m To n                    Total = Total + .Cells(j, 6)                Next                Set rng = .Range(.Cells(m, 1), .Cells(n, 1))                Call mergeRange(rng)                Set rng = .Range(.Cells(m, 2), .Cells(n, 2))                Call mergeRange(rng)                Set rng = .Range(.Cells(m, 7), .Cells(n, 7))                Call mergeRange(rng)                rng.Value = Total            End If        Next        Set rng = .Range(.Cells(2, 1), .Cells(currRow - 1, UBound(arrtemp)))        With rng            .Borders.LineStyle = 1            .WrapText = True        End With    End With    Application.DisplayAlerts = True    'Application.ScreenUpdating = TrueEnd SubSub mergeRange(rng As Range)    With rng        .Merge        .HorizontalAlignment = xlCenter    End WithEnd Sub

4、在myModule里，createList历程，把数据索取到SortedList：

Sub createList()    Dim ws As Worksheet, arr(), arrtemp()    Set deptList = CreateObject("System.Collections.SortedList")    '//把数据装入sortedList    For Each ws In ThisWorkbook.Sheets        If ws.Name = "上司考核" Or ws.Name = "自窥探核" Then            With ws                arr = .Range(.Cells(3, 1), .Cells(.UsedRange.Rows.Count, 8))                For i = 1 To UBound(arr)                    sKey = arr(i, 2)                    If sKey <> "" Then                        If Not deptList.contains(sKey) Then                            k = 1                        Else                            arrtemp = deptList.Item(sKey)                            k = UBound(arrtemp, 2) + 1                                                    End If                        ReDim Preserve arrtemp(1 To 8, 1 To k)                        For j = 1 To 7                            arrtemp(j, k) = arr(i, j)                        Next                        If ws.Name = "自窥探核" Then                            arrtemp(8, k) = "自查"   End If                        deptList(sKey) = arrtemp                    End If                Next            End With        End If    NextEnd Sub

5、在类模块classComboBox里，cmbBox的Change事件，把其他与之交流值的ComboxBox清空，幸免访佛。

Public WithEvents CmbBox As MSForms.ComboBoxPrivate Sub CmbBox_change()    Dim ws As Worksheet, currRow As Integer    Dim currCmbBox As OLEObject    Dim currKey As String    Set ws = ThisWorkbook.Sheets("发牌考核")    currRow = CInt(Replace(CmbBox.Name, "comb_", ""))    '//把其他与刻下控件值交流的清空    For i = 2 To deptList.Count + 1        If i <> currRow Then            Set currCmbBox = ws.OLEObjects("comb_" & i)            If currCmbBox.Object = CmbBox.Object Then                currCmbBox.Object = ""            End If        End If    Next    '//若是勾选自动更新，则调用update历程    If ws.OLEObjects("CkbAutoUpdate").Object.Value = True Then        Call update    End IfEnd Sub

6、在ThisWorkbook里小程序开发价格，使命簿Open事件,激活一次“发牌考核”表：

Private Sub Workbook_Open()    Dim ws As Worksheet    For Each ws In ThisWorkbook.Sheets        If ws.Name <> "发牌考核" Then            ws.Activate            Exit For        End If    Next    ThisWorkbook.Sheets("发牌考核").ActivateEnd Sub

~~~~~~End~~~~~~ 本站仅提供存储业绩，通盘推行均由用户发布，如发现存害或侵权推行，请点击举报。

• 小程序开发价格
• 部门
• 考核
• 汇总表
• 按遴

上一篇：小程序开发价格 21年前在街头卖猪肉的“北大屠户”，给母校捐钱9亿，如今怎样了？

下一篇：没有了