Slow running macro

Phil Payne

Phil Payne

Board Regular
Joined
May 17, 2013
Messages
131
Office Version
  1. 365
Platform
  1. Windows
I have worksheet macro that takes a very long time to run. There are only 47 target cells and it takes up to 30 seconds to complete!
Can anyone see how I can improve on this?
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
' This code checks for a change of Status in the Current Status column and
' on change sets (adjacent) cells' 'interior' and 'font ' colours according to table "rCodes".
    If Target.Count > 1 Then Exit Sub
    Dim rCell As Range
    Dim rCodes As Range
    Dim rRow As Range
    Dim vMatch
    Dim LastRow As Long
    LastRow = Range("A65536").End(xlUp).Row
    Set rCodes = Range("g6:g16")
    If (Target.Column >= 1) And (Target.Column <= Range("D1").Column) And (Target.Row <= LastRow) Then
        If Len(Target.Value) > 0 Then
            On Error Resume Next
            vMatch = Application.Match(Target.Value, rCodes, 0)
            If IsError(vMatch) Then
               'DO NOTHING
            Else
                With Target.Cells
                     .Offset(0, -1).Interior.Color = rCodes.Cells(vMatch).Interior.Color
                     .Offset(0, -1).Font.Color = rCodes.Cells(vMatch).Font.Color
                End With
            End If
        End If
    End If
End Sub
Thanks in anticipation.
Phil
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Sort by date Sort by votes
Phil Payne said:
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
' [B][COLOR=#FF0000]This code checks for a change of Status in the Current Status column [/COLOR][/B]and
' on change sets (adjacent) cells' 'interior' and 'font ' colours according to table "rCodes".
    If Target.Count > 1 Then Exit Sub
    Dim rCell As Range
    Dim rCodes As Range
    Dim rRow As Range
    Dim vMatch
    Dim LastRow As Long
    LastRow = Range("A65536").End(xlUp).Row
    Set rCodes = Range("g6:g16")
    If [COLOR=#008000][B](Target.Column >= 1) And (Target.Column <= Range("D1").Column)[/B][/COLOR] And (Target.Row <= LastRow) Then
        If Len(Target.Value) > 0 Then
            On Error Resume Next
            vMatch = Application.Match(Target.Value, rCodes, 0)
            If IsError(vMatch) Then
               'DO NOTHING
            Else
                With Target.Cells
                     [COLOR=#0000FF][B].Offset(0, -1).[/B][/COLOR]Interior.Color = rCodes.Cells(vMatch).Interior.Color
                     [B][COLOR=#0000FF].Offset(0, -1).[/COLOR][/B]Font.Color = rCodes.Cells(vMatch).Font.Color
                End With
            End If
        End If
    End If
End Sub
Click to expand...
I have a couple of questions for clarification. What I highlighted in red indicates a single status column, but what I highlighted in green is checking four columns for change. Won't a change in value in, say, Columns 4 change the colors in Column 3 (due to what I highlighted in blue)? At the same time, a change in value in Column 3 will change colors in Column 2? This seems odd and I just wanted to get a clarification about these overlaps. Also, your first test... Target.Column>=1... lets the column be 1, but what I colored in blue will try to offset one column to the left of that which doesn't exist... is that the reason for your "On Error Resume Next" statement? Maybe if you describe in words exactly what you expect this code to do, that would help us in developing a solution to your problem.
 
Upvote 0
.
.

I am also confused with the points raised by Rick.

However, perhaps something like this will help:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim rngChange As Range
    On Error Resume Next
    Set rngChange = Intersect(Target, Me.UsedRange, Me.Columns("B:D"))
    On Error GoTo 0
    
    If Not rngChange Is Nothing Then
    
        Dim rngCodes As Range
        Dim rngCell As Range
        Dim lMatch As Long
    
        Set rngCodes = Me.Range("G6:G16")
        For Each rngCell In rngChange.Cells
            If Not IsEmpty(rngCell) Then
                On Error Resume Next
                lMatch = WorksheetFunction.Match(rngCell.Value, rngCodes, 0)
                On Error GoTo 0
                If lMatch > 0 Then
                    With rngCell.Offset(0, -1)
                        .Interior.Color = rngCodes.Item(lMatch).Interior.Color
                        .Font.Color = rngCodes.Item(lMatch).Font.Color
                    End With
                End If
            End If
        Next rngCell
        
    End If
    
End Sub
 
Upvote 0
gpeacock said:
.
.

I am also confused with the points raised by Rick.

However, perhaps something like this will help:
Click to expand...
I think the code can be simplified quite a bit beyond what has been posted, but that is based on what I think the OP wants, but before spending time on such code, I would want to understand exactly what the OP expects the code to do (just in case my guess is wrong).
 
Upvote 0
Rick Rothstein said:
I think the code can be simplified quite a bit beyond what has been posted, but that is based on what I think the OP wants, but before spending time on such code, I would want to understand exactly what the OP expects the code to do (just in case my guess is wrong).
Click to expand...


Probably a good strategy. Making assumptions always causes trouble!
 
Upvote 0
Rick Rothstein said:
I think the code can be simplified quite a bit beyond what has been posted, but that is based on what I think the OP wants, but before spending time on such code, I would want to understand exactly what the OP expects the code to do (just in case my guess is wrong).
Click to expand...

Thanks for your prompt responses gents.

I should have provided the complete code which is now below. Hope this helps. I am being kicked off our PC now but will provide more details later if required.

Thanks again.


Code: 
Option Explicit

Private Sub ComboBox1_Change()
    Worksheets("CLO Print").Range("C8:C54").Select
    Selection.Interior.ColorIndex = xlAutomatic
    Selection.Font.ColorIndex = xlAutomatic

Application.ScreenUpdating = False
'The following lines of code are necessary to activate the 'on change' macro (at bottom here)
'which sets the cells interior colours and font relevant to the code number entered.
'Other column formulae are in held in cells.

'Column numbers are related to Data Sheet from Column A (C158 = column FB)
    ActiveSheet.Range("D8").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,13)"
    ActiveSheet.Range("D9").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,16)"
    ActiveSheet.Range("D10").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,19)"
    ActiveSheet.Range("D11").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,22)"
    ActiveSheet.Range("D12").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,25)"
    ActiveSheet.Range("D13").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,28)"
    ActiveSheet.Range("D14").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,31)"
    ActiveSheet.Range("D15").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,34)"
    ActiveSheet.Range("D16").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,37)"
    ActiveSheet.Range("D17").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,40)"
    ActiveSheet.Range("D18").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,43)"
    ActiveSheet.Range("D19").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,46)"
    ActiveSheet.Range("D20").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,49)"
    ActiveSheet.Range("D21").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,52)"
    ActiveSheet.Range("D22").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,55)"
    ActiveSheet.Range("D23").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,58)"
    ActiveSheet.Range("D24").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,61)"
    ActiveSheet.Range("D25").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,64)"
    ActiveSheet.Range("D26").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,67)"
    ActiveSheet.Range("D27").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,70)"
    ActiveSheet.Range("D28").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,73)"
    ActiveSheet.Range("D29").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,76)"
    ActiveSheet.Range("D30").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,79)"
    ActiveSheet.Range("D31").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,82)"
    ActiveSheet.Range("D32").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,85)"
    ActiveSheet.Range("D33").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,88)"
    ActiveSheet.Range("D34").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,91)"
    ActiveSheet.Range("D35").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,94)"
    ActiveSheet.Range("D36").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,97)"
    ActiveSheet.Range("D37").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,100)"
    ActiveSheet.Range("D38").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,103)"
    ActiveSheet.Range("D39").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,106)"
    ActiveSheet.Range("D40").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,109)"
    ActiveSheet.Range("D41").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,112)"
    ActiveSheet.Range("D42").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,115)"
    ActiveSheet.Range("D43").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,118)"
    ActiveSheet.Range("D44").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,121)"
    ActiveSheet.Range("D45").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,124)"
    ActiveSheet.Range("D46").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,127)"
    ActiveSheet.Range("D47").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,130)"
    ActiveSheet.Range("D48").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,133)"
    ActiveSheet.Range("D49").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,136)"
    ActiveSheet.Range("D50").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,139)"
    ActiveSheet.Range("D51").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,142)"
    ActiveSheet.Range("D52").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,145)"
    ActiveSheet.Range("D53").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,148)"
    ActiveSheet.Range("D54").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP(R5C3,'Data Sheet'!R15C6:R145C158,151)"
    ActiveSheet.Range("D55").Select
    Application.ScreenUpdating = True

ActiveSheet.Range("A1").Select
End Sub





Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
' This code checks for a change of Status in the Current Status column (D) and
' on change sets cells 'interior' and 'font ' colours according to table "rCodes".
' The range covered extends from column ‘A’ (first Status column), to column ‘D’ (Current Status Column).

    If Target.Count > 1 Then Exit Sub
    Dim rCell As Range
    Dim rCodes As Range
    Dim rRow As Range
    Dim vMatch
    Dim LastRow As Long

    LastRow = Range("A65536").End(xlUp).Row
    Set rCodes = Range("g6:g16")
    If (Target.Column >= 1) And (Target.Column <= Range("D1").Column) And (Target.Row <= LastRow) Then
        If Len(Target.Value) > 0 Then
            On Error Resume Next
            vMatch = Application.Match(Target.Value, rCodes, 0)
            If IsError(vMatch) Then
               'DO NOTHING
            Else
                With Target.Cells
                     .Offset(0, -1).Interior.Color = rCodes.Cells(vMatch).Interior.Color
                     .Offset(0, -1).Font.Color = rCodes.Cells(vMatch).Font.Color
                End With
            End If
        End If
    End If
Application.ScreenUpdating = True
End Sub
 
Upvote 0
gpeacock said:
.
.

I am also confused with the points raised by Rick.

However, perhaps something like this will help:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    
    Dim rngChange As Range
    On Error Resume Next
    Set rngChange = Intersect(Target, Me.UsedRange, Me.Columns("B:D"))
    On Error GoTo 0
    
    If Not rngChange Is Nothing Then
    
        Dim rngCodes As Range
        Dim rngCell As Range
        Dim lMatch As Long
    
        Set rngCodes = Me.Range("G6:G16")
        For Each rngCell In rngChange.Cells
            If Not IsEmpty(rngCell) Then
                On Error Resume Next
                lMatch = WorksheetFunction.Match(rngCell.Value, rngCodes, 0)
                On Error GoTo 0
                If lMatch > 0 Then
                    With rngCell.Offset(0, -1)
                        .Interior.Color = rngCodes.Item(lMatch).Interior.Color
                        .Font.Color = rngCodes.Item(lMatch).Font.Color
                    End With
                End If
            End If
        Next rngCell
        
    End If
    
End Sub
Click to expand...

Hi G
Thanks.
Your code worked without modification, however it made no difference to the time taken to complete the task - 20 seconds.
Phil
 
Upvote 0
If you step through the code - I haven't, I've only looked at the thread for a minute - do you see other event code being triggered?

If so & you don't want it/them, add 'application.enableevents = false' near the top of your code and the reverse near the bottom. 'application.enbleevents=true'

OK?

cheers
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
Prevent worksheet change from triggering when similar macro is executed?
Replies
1
Views
97
AlphaFrog
AlphaFrog
M
  • Solved
vba to sum up each column for each employee on column (A)
Replies
6
Views
298
kvsrinivasamurthy
K
S
  • Question Question
Macro Copy and Paste Value and formatting in multiple same cells when condition is met.
Replies
4
Views
276
RobP
R
A
  • Question Question
VBA highlight blank cells in a range and their corresponding headers
Replies
7
Views
467
AnnAnn
A
G
  • Solved
If Else Loop macro running slow, anyway to speed it up?
Replies
9
Views
258
Alex Blakenburg
A

Forum statistics

Threads
1,223,231
Messages
6,170,884
Members
452,364
Latest member
springate

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top