条件高亮：如何优化？

Question

我的代码完全符合我的要求。我的代码基础来自于 Tim Williams 在之前的question 中的慷慨帮助。在他的帮助下，我稍微添加了一些功能（更大的字体大小，如果未选择列中的任何内容，则将格式恢复为原始格式），并将代码扩展到多个列，如代码所示。

问题是我的电子表格现在慢得令人无法忍受。有没有办法加快速度？

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim r As Range, c As Range

    'Set target for all columns that have this functionality
    Set r = Intersect(Me.Range("N:Q"), Target)

    'The functionality is repeated for several columns and is identical each time (except for N which maps to two columns)

    'Column N maps to columns H & I
    If Not Application.Intersect(Target, Range("N:N")) Is Nothing Then

    If r Is Nothing Or Target.Cells.CountLarge > 960 Then Exit Sub

    Application.ScreenUpdating = False
        HighlightIt Application.Intersect(Me.Range("H:I"), Me.UsedRange), False
        For Each c In r.Cells
            HighlightIt Me.Cells(c.Row, "H").Resize(1, 2)
        Next c

    Else
         With Application.Intersect(Me.Range("H:I"), Me.UsedRange)
            .Font.Bold = False
            .Font.Color = vbBlack
            .Font.Size = 14

          End With
    End If

    'Column O maps to columns J
     If Not Application.Intersect(Target, Range("O:O")) Is Nothing Then

    If r Is Nothing Or Target.Cells.CountLarge > 960 Then Exit Sub

    Application.ScreenUpdating = False
        HighlightIt Application.Intersect(Me.Range("J:J"), Me.UsedRange), False
        For Each c In r.Cells
            HighlightIt Me.Cells(c.Row, "J")
        Next c


    Else
         With Application.Intersect(Me.Range("J:J"), Me.UsedRange)
            .Font.Bold = False
            .Font.Color = vbBlack
            .Font.Size = 14

          End With
    End If


   'Column P maps to columns K
    If Not Application.Intersect(Target, Range("P:P")) Is Nothing Then

    If r Is Nothing Or Target.Cells.CountLarge > 960 Then Exit Sub

    Application.ScreenUpdating = False
        HighlightIt Application.Intersect(Me.Range("K:K"), Me.UsedRange), False
        For Each c In r.Cells
            HighlightIt Me.Cells(c.Row, "K")
        Next c

    Else
         With Application.Intersect(Me.Range("K:K"), Me.UsedRange)
            .Font.Bold = False
            .Font.Color = vbBlack
            .Font.Size = 14

          End With
    End If

    'Column Q maps to columns L
    If Not Application.Intersect(Target, Range("Q:Q")) Is Nothing Then

    If r Is Nothing Or Target.Cells.CountLarge > 960 Then Exit Sub

    Application.ScreenUpdating = False
        HighlightIt Application.Intersect(Me.Range("L:L"), Me.UsedRange), False
        For Each c In r.Cells
            HighlightIt Me.Cells(c.Row, "L")
        Next c

       Else
         With Application.Intersect(Me.Range("L:L"), Me.UsedRange)
            .Font.Bold = False
            .Font.Color = vbBlack
            .Font.Size = 14

          End With
    End If

End Sub

'utility sub for highlighting/unhighlighting
Sub HighlightIt(rng As Range, Optional hilite As Boolean = True)
    With rng
        .Font.Color = IIf(hilite, vbWhite, vbBlack)
        .Font.Bold = hilite
        .Font.Size = IIf(hilite, 20, 14)
    End With
End Sub

Answer 1

达伦·巴特鲁普是对的。 Code Review 是一个很好的网站，可以帮助您提高代码效率。

我提供了一个答案，因为我不确定您是否完全理解 Tim Williams 的答案。除了不需要迭代单元格之外，您还应该能够为每个测试列不使用相同的代码。您可以通过创建某种形式的选定列来突出显示列映射来做到这一点。下面是帮助您入门的框架代码。

您提供的代码不应该像您描述的那么慢，所以我想知道您是否正在处理其他事件（或者您的 _Select 事件中有更多代码）。如果有，请确保将其包含在代码审查或此处的问题中。

Option Explicit

Private mColumnMap As Collection
Private mOldRange As Range
Private mOldCellColour As Long

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim mappedRange As Range
    Dim mappedCells As Range

    'Define the column map.
    If mColumnMap Is Nothing Then
        Set mColumnMap = New Collection

        mColumnMap.Add Me.Range("H:I"), "14" 'N
        mColumnMap.Add Me.Range("J:J"), "15" 'O
        mColumnMap.Add Me.Range("K:K"), "16" 'P
        mColumnMap.Add Me.Range("L:L"), "17" 'Q
    End If

    'If there is a highlighted range, change it back.
    If Not mOldRange Is Nothing Then
        With mOldRange
            .Interior.Color = mOldCellColour
            .Font.Bold = False
        End With
        Set mOldRange = Nothing
    End If

    'Ignore any selections that are more than one column.
    If Target.Columns.Count <> 1 Then Exit Sub

    'Ignore any selections outside of a specified range.
    'Note: I've just used the 'UsedRange'.
    If Intersect(Target, Me.UsedRange) Is Nothing Then Exit Sub

    'Acquire the appropriate column map.
    On Error Resume Next
    Set mappedRange = mColumnMap(CStr(Target.Column))
    On Error GoTo 0

    'Exit if not a target column.
    If mappedRange Is Nothing Then Exit Sub

    'Define the cells to be changed.
    Set mappedCells = Intersect(mappedRange, Target.EntireRow)

    'Store the original values.
    Set mOldRange = mappedCells
    mOldCellColour = mappedCells(1).Interior.Color

    'Change the values.
    Application.ScreenUpdating = False
    With mappedCells
        .Interior.Color = vbWhite
        .Font.Bold = True
    End With
    Application.ScreenUpdating = True

End Sub