CODEWITHSUNDEEP
vbaexcel
dibyendu
dibyendu

Reputation: 7

VBA code takes long time to execute

The followinf VBA code takes long time to execute

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

If this code can be modified to run fast. or, if any alternative VBA code that can be written to highlight value(in red color) in worksheet "Reviews" of column range "D1:D30" when matches in worksheet "Input" of cell number "M3". Thanks

Upvotes: 1

Views: 164

Answers (3)

paul bica
paul bica

Reputation: 10705

Another option using AutoFilter (fast for large data sets)

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

Upvotes: 2

Subodh Tiwari sktneer
Subodh Tiwari sktneer

Reputation: 9976

Try it like this...

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

Upvotes: 1

user4039065
user4039065

Reputation:

I would tackle this with a Conditional Formatting Rule.

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

Upvotes: 4

Related Questions