内容提要

考核汇总表（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~~~~~~ 本站仅提供存储服务，所有内容均由用户发布，如发现有害或侵权内容，请点击举报。