本色摘要萝莉 崩坏：星穹铁道

考核汇总表（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控件：

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~~~~~~ 本站仅提供存储作事，扫数本色均由用户发布，如发现存害或侵权本色，请点击举报。