时间戳

首页 > 解决方案 > 用不同颜色格式化单元格的 VBA 脚本，慢速电子表格

excel - 用不同颜色格式化单元格的 VBA 脚本，慢速电子表格

问题描述

我是 VBA 的新手，这是我的第一个 VBA 脚本，它看起来已经足够好了，但是它让我的电子表格变得非常慢，我可以做一些优化它。

脚本遍历一些定义的列并检查内容“A”“S”等，如果内容匹配，脚本必须将单元格着色为特定颜色，并将右侧的单元格着色

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim My_Range As Range
Set My_Range = Worksheets("Sæson").Range("J10:J40,Q10:Q39,X10:X40,AE10:AE39,AL10:AL40,AS10:AS40,AZ10:AZ39,BG10:BG40,BN10:BN39,BU10:BU40,CB10:CB40,CI10:CI38,CP10:CP40")
For Each cell In My_Range
   If cell.Value = "S" Then
      cell.Interior.Color = RGB(0, 255, 255)
      cell.Offset(0, 1).Interior.Color = RGB(0, 255, 255)
   ElseIf cell.Value = "FE" Then
      cell.Interior.Color = RGB(255, 192, 0)
      cell.Offset(0, 1).Interior.Color = RGB(255, 192, 0)
   ElseIf cell.Value = "SF" Then
      cell.Interior.Color = RGB(255, 192, 0)
      cell.Offset(0, 1).Interior.Color = RGB(255, 192, 0)
   ElseIf cell.Value = "T" Then
      cell.Interior.Color = RGB(49, 255, 33)
      cell.Offset(0, 1).Interior.Color = RGB(49, 255, 33)
   ElseIf cell.Value = "TK" Then
      cell.Interior.Color = RGB(0, 176, 240)
      cell.Offset(0, 1).Interior.Color = RGB(0, 176, 240)
   ElseIf cell.Value = "TH" Then
      cell.Interior.Color = RGB(255, 153, 204)
      cell.Offset(0, 1).Interior.Color = RGB(255, 153, 204)
   ElseIf cell.Value = "SY" Then
      cell.Interior.Color = RGB(255, 0, 0)
      cell.Offset(0, 1).Interior.Color = RGB(255, 0, 0)
   Else
      cell.Interior.Color = xlNone
      cell.Offset(0, 1).Interior.Color = xlNone
   End If
Next
End Sub

标签： excelvba

解决方案

应用标准颜色

  • 假定源区域的单元格包含公式。每次工作表重新计算时，这将自动将颜色重新应用到整个范围（事件驱动），这不一定意味着范围中的值已更改（效率不高）。不过，在这个小范围内它应该非常快。
  • 如果单元格包含值，那么您可以手动运行applyCriteriaColors以获得所需的结果。此外，解决方案将是为Worksheet_Change事件编写的不同代码（您不能使用这个）。
  • 将代码复制到相应的模块。
  • 调整常量部分中的值。

标准模块 例如Module1

Option Explicit

Sub applyCriteriaColors()

    Const wsName As String = "Sheet1"
    ' The number of columns to apply the color to.
    Const ColCount As Long = 2
    ' "cRangesList" has to contain a list of addresses of ONE-column ranges.
    Const cRangesList As String = "J10:J40,Q10:Q39,X10:X40,AE10:AE39," _
        & "AL10:AL40,AS10:AS40,AZ10:AZ39,BG10:BG40,BN10:BN39,BU10:BU40," _
        & "CB10:CB40,CI10:CI38,CP10:CP40"
    ' "CriteriaList" and "CellColors" have to have the same number of elements.
    ' Note that "Ranges" has the same number of elements (ranges) as well.
    Const CriteriaList As String = "S,FE,SF,T,TK,TH,SY"
    Dim CellColors As Variant: CellColors = VBA.Array( _
        16776960, 49407, 49407, 2228017, 15773696, 13408767, 255)
    
    ' Write values from Criteria List to Criteria Array.
    Dim Criteria() As String: Criteria = Split(CriteriaList, ",")
    ' Calculate Ranges Count (not to be confused with "aCount").
    Dim rCount As Long: rCount = UBound(Criteria) + 1
    ' Define Ranges Array.
    Dim Ranges() As Range: ReDim Ranges(1 To rCount)
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Define Source Range.
    Dim srg As Range: Set srg = wb.Worksheets(wsName).Range(cRangesList)
    ' Calculate Source Range Areas Count, the number of elements in Data Array.
    Dim aCount As Long: aCount = srg.Areas.Count
    ' Define Data Array (of Arrays).
    Dim Data As Variant: ReDim Data(1 To aCount)
    ' Define One-Cell Array.
    Dim OneCell As Variant: ReDim OneCell(1 To 1, 1 To 1)
        
    Dim arg As Range ' Source Range Current Area
    Dim cValue As Variant ' Current Value
    Dim cMatch As Variant ' Current Match
    Dim n As Long ' Source Range Areas Counter, Ranges Array Ranges Counter
    Dim i As Long ' Current Array (of Data Array) Rows Counter
    
    For n = 1 To aCount
        ' Write values from current area ('srg.Areas(n)') of Source Range
        ' ('srg') to current array ('Data(n)') of Data Array ('Data').
        Set arg = srg.Areas(n) '.Columns(1) ' ... ONE-column ranges
        If arg.Rows.Count > 1 Then
            Data(n) = arg.Value
        Else
            Data(n) = OneCell: Data(1, 1) = arg.Value
        End If
        For i = 1 To UBound(Data(n), 1)
            cValue = Data(n)(i, 1)
            If Not IsError(cValue) Then
                If Len(cValue) > 0 Then
                    ' Attempt to find a match in Criteria Array.
                    cMatch = Application.Match(cValue, Criteria, 0)
                    If IsNumeric(cMatch) Then
                        ' Combine matched cell resized by "ColCount"
                        ' with 'associated' range in Ranges Array.
                        If Ranges(cMatch) Is Nothing Then
                            Set Ranges(cMatch) _
                                = arg.Cells(i).Resize(, ColCount)
                        Else
                            Set Ranges(cMatch) = Union(Ranges(cMatch), _
                                arg.Cells(i).Resize(, ColCount))
                        End If
                    End If
                End If
            End If
        Next i
    Next n
    
    Application.ScreenUpdating = False
    ' Reset colors. Note that "Resize" doesn't work with multi-area ranges.
    For n = 1 To aCount
        srg.Areas(n).Resize(, ColCount).Interior.Color = xlNone
    Next n
    ' Apply colors to the 'combined' ranges.
    For n = 1 To rCount
        If Not Ranges(n) Is Nothing Then
            Ranges(n).Interior.Color = CellColors(n - 1)
        End If
    Next n
    Application.ScreenUpdating = True

End Sub

表模块例如Sheet1

Option Explicit

Private Sub Worksheet_Calculate()
    applyCriteriaColors
End Sub

推荐阅读