自己做的一个聚光灯。

winner0769

向大神學習，向大神致敬！！

361478294

win7  64位  07版亲测   打开后不能复制粘贴.   请楼主改进  

may31110

谢谢！可是不知道干什么用！

楼阁台西

易用宝不是有呢我

ctp_119

may31110 发表于 2015-8-6 14:39
谢谢！可是不知道干什么用！

对账时，防止看花眼的！！！对错行或列的！！！仅此而已！！！

Laolangsex

我的聚光灯，代码贡献
功能：可以选择行、列、十字、删除。
不影响复制等操作，支持64位OFFICE

Sub ALTJ() '菜单栏
    Dim BarS As CommandBar
    Dim ButA As CommandBarButton
    Dim Shelp, Fhelp, PicS, PicF, Naction
    Dim i As Integer
   
    Shelp = Array("删除亮显", "行列亮显", "列亮显", "行亮显", "自动换行", "回车下移") '标题
    PicS = Array("PIC_D", "PIC_CR", "PIC_C", "PIC_R", "H_H", "H_C") '图片
    Naction = Array("DEl_code", "add_code_RC", "add_code_C", "add_code_R", "zdhh", "hcXX") '程序
   
    Set BarS = Application.CommandBars("standard")
    For i = 1 To 6
        Set ButA = BarS.Controls.Add(Type:=msoControlButton, Before:=10, temporary:=True)
        函数表.Shapes(PicS(i - 1)).Copy
        With ButA
            .Caption = Shelp(i - 1)
            .OnAction = Naction(i - 1)
            .PasteFace
        End With
    Next
   End Sub

'代码插入
Sub Add_Code(TypeM As Integer, Control As IRibbonControl)
   
    Dim StarlineN As Long, R As Integer, i As Long
    Dim DmA As String, DmB As String
    Dim Bzf As Boolean
   
    On Error Resume Next
   
    [ChangColor_Row].FormatConditions.Delete
    [ChangColor_Col].FormatConditions.Delete
    [SeleCtion_Cell].FormatConditions.Delete
   
    DmA = "application.run " & """" & "I_Code" & """" & "," & TypeM & "'[YVCBIWKH200505]"
    DmB = "Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)" & vbCrLf _
            & DmA & vbCrLf _
            & "End Sub"
   
    With ActiveWorkbook.VBProject.VBComponents(ThisWorkbook.CodeName).CodeModule
        StarlineN = .ProcStartLine("Workbook_SheetSelectionChange", vbext_pk_Proc)
        If StarlineN = 0 Then '程序不存在时，添加
            .AddFromString DmB
        Else
            For i = StarlineN To .CountOfLines
                Bzf = .Find("[YVCBIWKH200505]", StarlineN, 0, i, 0, False, True, True)
                If Bzf Then
                    Exit For
                End If
            Next
            If Bzf Then
                .ReplaceLine i, DmA
            Else
                .InsertLines .ProcStartLine("Workbook_SheetSelectionChange", vbext_pk_Proc) + 1, DmA
            End If
        End If
    End With
   
End Sub

'行亮显
Sub Add_Code_R(Control As IRibbonControl)
    Add_Code 1, Control
End Sub

'列亮显
Sub Add_Code_C(Control As IRibbonControl)
    Add_Code 2, Control
End Sub

'行列亮显
Sub Add_Code_RC(Control As IRibbonControl)
    Add_Code 3, Control
End Sub

'执行模块
Sub I_Code(i As Integer)

    Dim BzA As Boolean, BzB As Boolean
   
    On Error Resume Next
   
    [ChangColor_Row].FormatConditions.Delete
    [ChangColor_Col].FormatConditions.Delete
    [SeleCtion_Cell].FormatConditions.Delete
   
    Selection.Name = "Selection_Cell"
    Selection.EntireRow.Name = "ChangColor_Row"
    Selection.EntireColumn.Name = "ChangColor_Col"
   
    BzA = Abs(i - 2)
    BzB = Abs(i - 1)
   
    If BzA Then '行
        With [ChangColor_Row].FormatConditions
            .Delete
            .Add xlExpression, , "TRUE"
            .Item(1).Interior.ColorIndex = 24
        End With
    End If
        
    If BzB Then '列
        With [ChangColor_Col].FormatConditions
            .Delete
            .Add xlExpression, , "TRUE"
            .Item(1).Interior.ColorIndex = 24
        End With
    End If
   
    '单元格
    With [SeleCtion_Cell].FormatConditions
        .Delete
        .Add xlExpression, , "TRUE"
        .Item(1).Interior.ColorIndex = 7
        .Item(1).Font.ColorIndex = 2
    End With
   
End Sub

'删除亮显
Sub Del_Code(Control As IRibbonControl)

    Dim StarlineN As Long, R As Integer, i As Long, DmA As String, Bzf As Boolean
   
    On Error Resume Next
   
    With ActiveWorkbook.VBProject.VBComponents(ThisWorkbook.CodeName).CodeModule
        StarlineN = .ProcStartLine("Workbook_SheetSelectionChange", vbext_pk_Proc)
       ' MsgBox StarlineN
        For i = StarlineN To .CountOfLines
            Bzf = .Find("[YVCBIWKH200505]", StarlineN, 0, i, 0, False, True, True)
            If Bzf Then Exit For
        Next
        If Bzf Then
            .DeleteLines i, 1
        Else
            MsgBox "没有发现代码"
        End If
    End With
   
    [ChangColor_Row].FormatConditions.Delete
    [ChangColor_Col].FormatConditions.Delete
    [SeleCtion_Cell].FormatConditions.Delete
    ActiveWorkbook.Names("ChangColor_Row").Delete
    ActiveWorkbook.Names("ChangColor_Col").Delete
    ActiveWorkbook.Names("Selection_Cell").Delete
   
End Sub

ctp_119

Laolangsex 发表于 2015-8-10 15:36
我的聚光灯，代码贡献
功能：可以选择行、列、十字、删除。
不影响复制等操作，支持64位OFFICE

最好把附件也上传上来，大家可以互相学习！！！

may31110

ctp_119 发表于 2015-8-8 09:27
对账时，防止看花眼的！！！对错行或列的！！！仅此而已！！！

哦，谢谢！普及姿势！

02761752696

感谢分享，学习

361478294

ctp_119 发表于 2015-8-8 09:27
对账时，防止看花眼的！！！对错行或列的！！！仅此而已！！！

win7  64位  07版亲测   打开后不能复制粘贴.   请楼主改进      8月6号发的,没看见啊?