Question

以下VBA代码需要很长时间才能执行

Dim rngCol1 As Range
Dim rngCol2 As Range
Dim myvalue As Long
Dim c As Range

Set rngCol1 = ThisWorkbook.Sheets("Reviews").Range("D1:D30" & Range("D" & Rows.Count).End(xlUp).Row)
Set rngCol2 = ThisWorkbook.Sheets("Input").Range("M3")

For Each c In rngCol1
    On Error Resume Next
    If IsError(myvalue = WorksheetFunction.Match(c.Value, rngCol2, 0)) Then
    Else
        c.Font.Color = vbRed
    End If
Next

如果可以修改此代码以快速运行。或者，如果在单元格编号“M3”的工作表“输入”中匹配时，可以在工作表“评论”中列出范围“D1：D30”时可以写入以突出显示值（红色）的任何替代VBA代码。感谢

Answer 1

我会用条件格式规则解决这个问题。

Dim addr As String
With ActiveWorkbook.Worksheets("Reviews")
    With .Range(.Cells(1, "D"), .Cells(.Rows.Count, "D").End(xlUp))
        addr = .Cells(1).Address(False, True)
        .FormatConditions.Delete
        With .FormatConditions.Add(Type:=xlExpression, Formula1:="=and(" & addr & "='Input'!$M$3, not(isblank(" & addr & ")))")
            .Interior.Color = 255    'red
        End With
    End With
End With

Answer 2

使用AutoFilter的另一个选项（快速用于大型数据集）

Option Explicit

Public Sub ShowMatches()
    Dim srcVal As Variant, hdr As Long

    srcVal = ThisWorkbook.Sheets("Input").Range("M3")

    If Not IsError(srcVal) Then
        With ThisWorkbook.Sheets("Reviews").UsedRange.Columns(4)
            .AutoFilter Field:=1, Criteria1:="=" & srcVal
            If .SpecialCells(xlCellTypeVisible).CountLarge > 1 Then
                hdr = Abs(.Cells(1) <> srcVal)
                .offset(hdr).Resize(.Rows.Count - hdr, 1).Font.Color = vbRed
            End If
            .AutoFilter
        End With
    End If
End Sub

Answer 3

尝试这样......

Dim rngCol1 As Range
Dim rngCol2 As Range
Dim myvalue
Dim c As Range

Set rngCol1 = ThisWorkbook.Sheets("Reviews").Range("D1:D" & Range("D" & Rows.Count).End(xlUp).Row)
Set rngCol2 = ThisWorkbook.Sheets("Input").Range("M3")

For Each c In rngCol1
    myvalue = Application.Match(c.Value, rngCol2, 0)
    If Not IsError(myvalue) Then
        c.Font.Color = vbRed
    End If
Next

已编辑的代码：

Dim ws1 As Worksheet, ws2 As Worksheet
Dim rngCol1 As Range
Dim rngCol2 As Range
Dim myvalue
Dim c As Range

Application.ScreenUpdating = False

Set ws1 = ThisWorkbook.Sheets("Reviews")
Set ws2 = ThisWorkbook.Sheets("Input")
Set rngCol1 = ws1.Range("D1:D" & ws1.Range("D" & Rows.Count).End(xlUp).Row)
Set rngCol2 = ws2.Range("M3")

For Each c In rngCol1
    myvalue = Application.Match(c.Value, rngCol2, 0)
    If Not IsError(myvalue) Then
        c.Font.Color = vbRed
    End If
Next

Application.ScreenUpdating = True

VBA代码需要很长时间才能执行

3 个答案: