常用功能加载宏——单元格聚光灯

xyj

发布于 2020-07-28 11:51:36

1.1K0

发布于 2020-07-28 11:51:36

文章被收录于专栏：VBA 学习VBA 学习

如果Excel表格里数据比较多的时候，查看数据很容易看错行，这时候如果给要查看的这行数据标记颜色，那么查看数据就方便多了。

如果每次都手动去标记颜色，又手动去取消颜色，这肯定会很麻烦，给需要这种功能的表格添加一个“聚光灯”功能就非常的方便了：

首先在customUI.xml中增加代码：

      <button id="rbbtnHighLight" label="聚光灯&#13;" size="large" onAction="rbbtnHighLight" imageMso="PictureBrightnessGallery"/>

回调函数：

Sub rbbtnHighLight(control As IRibbonControl)
    Call MRange.HighLight
End Sub

函数实现：

'聚光灯
Sub HighLight()
    Dim str_insert_code As String
    Dim str_code As String
    Dim i As Long
    
    '构建Worksheet_SelectionChange事件代码
    str_insert_code = vbNewLine & "Private Sub Worksheet_SelectionChange(ByVal Target As Range)"
    
    str_insert_code = str_insert_code & vbNewLine & "   If Application.CutCopyMode = False Then"
                                
    str_insert_code = str_insert_code & vbNewLine & "         ActiveSheet.Calculate"
    
    str_insert_code = str_insert_code & vbNewLine & "   End If"
    
    str_insert_code = str_insert_code & vbNewLine & "End Sub"

    
    For i = 1 To ActiveWorkbook.VBProject.VBComponents.Count
        '找到活动工作表组件
        If ActiveWorkbook.VBProject.VBComponents(i).Name = ActiveSheet.CodeName Then

            With ActiveWorkbook.VBProject.VBComponents(i).CodeModule
                str_code = .Lines(1, .CountOfLines)
                
                '没有Worksheet_SelectionChange事件代码的情况下，插入代码
                If VBA.InStr(str_code, "Worksheet_SelectionChange") = 0 Then
                    .InsertLines .CountOfLines + 2, str_insert_code
                    '设置数据有效性
                    With Cells.FormatConditions
                        .Delete
                        .Add(xlExpression, Formula1:="=CELL(""row"")=ROW()").Interior.ColorIndex = 27
                    End With
                End If
            End With

            Exit For
        End If
    Next i
End Sub

这个功能的原理就是在当前活动工作表中，首先插入Worksheet_SelectionChange代码：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   If Application.CutCopyMode = False Then
         ActiveSheet.Calculate
   End If
End Sub

只要选择改变的情况下，重新计算。

重新计算的目的就是为了激活条件格式中的函数：