Question

我有可以完全实现我想要的代码。我的代码的基础来自蒂姆·威廉姆斯在上一期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

达伦·巴特鲁普（Darren Bartrup）是对的。代码审查是一个很好的网站，可以帮助您提高代码效率。

我正在提供答案，因为我不确定您是否有蒂姆·威廉姆斯（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

有条件的突出显示：如何优化？

1 个答案: