VBA-Code dauert lange

Question

Der followinf VBA-Code dauert lange Zeit auszuführen

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 

Wenn dieser Code geändert werden, um ausführen kann, schnell zu laufen. oder, wenn irgendein alternativer VBA-Code geschrieben werden kann, um den Wert (in roter Farbe) im Arbeitsblatt "Reviews" des Spaltenbereichs "D1: D30" zu markieren, wenn das Arbeitsblatt "Input" der Zellennummer "M3" übereinstimmt. Dank

Answer 1

Probieren Sie es so ...

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 

Edited Code:

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 

Answer 2

Ich würde dies angehen mit einer bedingten Formatierung Regel.

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 3

Eine weitere Option Autofilter verwenden (schnell für große Datenmengen)

---

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