Help Speed up this Loop?!?

**arleutwyler** · 07-05-2013, 11:17 PM

Hi all, I have successfully created a sub that looks for 7 particular colors and add a pattern style to those cells. The problem I have with what I have created is that it is slow... not crazy slow but slow enough to make the end user think that the program has frozen. Any help would be huge!

Sub REcolorer()
Application.ScreenUpdating = False
    Dim cl As Range
    Dim active_rng As Range
        Set active_rng = Range("A2:MM1200")
        For Each cl In active_rng
            If cl.Interior.Color = RGB(204, 255, 255) Then
                With cl.Interior
                .Pattern = xlGray8
                .PatternThemeColor = xlThemeColorDark1
                .TintAndShade = 0
                .PatternTintAndShade = -0.499984740745262
                End With
            End If
        Next cl
        Application.ScreenUpdating = True

For Each cl In active_rng
            If cl.Interior.Color = RGB(204, 255, 204) Then
                With cl.Interior
                .Pattern = xlGray8
                .PatternThemeColor = xlThemeColorDark1
                .TintAndShade = 0
                .PatternTintAndShade = -0.499984740745262
                End With
            End If
        Next cl
        
For Each cl In active_rng
            If cl.Interior.Color = RGB(255, 255, 153) Then
                With cl.Interior
                .Pattern = xlGray8
                .PatternThemeColor = xlThemeColorDark1
                .TintAndShade = 0
                .PatternTintAndShade = -0.499984740745262
                End With
            End If
        Next cl

For Each cl In active_rng
            If cl.Interior.Color = RGB(153, 204, 255) Then
                With cl.Interior
                .Pattern = xlGray8
                .PatternThemeColor = xlThemeColorDark1
                .TintAndShade = 0
                .PatternTintAndShade = -0.499984740745262
                End With
            End If
        Next cl

For Each cl In active_rng
            If cl.Interior.Color = RGB(255, 153, 204) Then
                With cl.Interior
                .Pattern = xlGray8
                .PatternThemeColor = xlThemeColorDark1
                .TintAndShade = 0
                .PatternTintAndShade = -0.499984740745262
                End With
            End If
        Next cl
        
For Each cl In active_rng
            If cl.Interior.Color = RGB(204, 153, 255) Then
                With cl.Interior
                .Pattern = xlGray8
                .PatternThemeColor = xlThemeColorDark1
                .TintAndShade = 0
                .PatternTintAndShade = -0.499984740745262
                End With
            End If
        Next cl
        
For Each cl In active_rng
            If cl.Interior.Color = RGB(255, 204, 153) Then
                With cl.Interior
                .Pattern = xlGray8
                .PatternThemeColor = xlThemeColorDark1
                .TintAndShade = 0
                .PatternTintAndShade = -0.499984740745262
                End With
            End If
        Next cl
End Sub

Thank you!
Alex

**billstpierre79** · 07-05-2013, 11:38 PM

I didn't test this but it should work. You were cycling through the data 7 times. This code will go through the data only once and check all of the criteria that you set.

Sub REcolorer()
Application.ScreenUpdating = False
    Dim cl As Range
    Dim active_rng As Range
        Set active_rng = Range("A2:MM1200")
        For Each cl In active_rng
            If cl.Interior.Color = RGB(204, 255, 255) Or _
            (cl.Interior.Color = RGB(204, 255, 204)) Or _
            (cl.Interior.Color = RGB(255, 255, 153)) Or _
            (cl.Interior.Color = RGB(153, 204, 255)) Or _
            (cl.Interior.Color = RGB(255, 153, 204)) Or _
            (cl.Interior.Color = RGB(204, 153, 255)) Or _
            (cl.Interior.Color = RGB(255, 204, 153)) Then
                With cl.Interior
                .Pattern = xlGray8
                .PatternThemeColor = xlThemeColorDark1
                .TintAndShade = 0
                .PatternTintAndShade = -0.499984740745262
                End With
            End If
        Next cl
      Application.screenupdating=true
End Sub

**arleutwyler** · 07-05-2013, 11:47 PM

Thanks for the fast reply! I ran your code and it seems move just a touch faster... just a touch. I am pretty new to VBA and I don't know if there is a better way to do this... I am open to any suggestions! Lets make this faster!!!

Thank you again,
Alex

**billstpierre79** · 07-05-2013, 11:59 PM

That's as fast as its going to move. Its checking over 46000 cells. But if you want the end user to know that the program is still running try this code. It will display "Running Macro" in the status bar while the code is running.

Sub REcolorer()
Application.ScreenUpdating = False
    Dim cl As Range
    Dim active_rng As Range
        Set active_rng = Range("A2:MM1200")
        For Each cl In active_rng
        Application.StatusBar = "Running Macro"
            If cl.Interior.Color = RGB(204, 255, 255) Or _
            (cl.Interior.Color = RGB(204, 255, 204)) Or _
            (cl.Interior.Color = RGB(255, 255, 153)) Or _
            (cl.Interior.Color = RGB(153, 204, 255)) Or _
            (cl.Interior.Color = RGB(255, 153, 204)) Or _
            (cl.Interior.Color = RGB(204, 153, 255)) Or _
            (cl.Interior.Color = RGB(255, 204, 153)) Then
                With cl.Interior
                .Pattern = xlGray8
                .PatternThemeColor = xlThemeColorDark1
                .TintAndShade = 0
                .PatternTintAndShade = -0.499984740745262
                End With
            End If
        Next cl
        Application.StatusBar = False
End Sub

**arleutwyler** · 07-06-2013, 12:26 AM

Hmm well maybe I need to go about this a different way.

Right now I am using event code (sheet code) to fill cells that are changed with different colors for everyday of the week. (below)

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim TodaysColor As Long
    If Target.Count = 1 Then
        If Target.Row > 1 Then
            Select Case Weekday(Date)
                Case vbSunday: TodaysColor = RGB(204, 255, 255)     'Turquoise
                Case vbMonday: TodaysColor = RGB(204, 255, 204)     'Lt Green
                Case vbTuesday: TodaysColor = RGB(255, 255, 153)    'Lt Yellow
                Case vbWednesday: TodaysColor = RGB(153, 204, 255)  'Lt Blue
                Case vbThursday: TodaysColor = RGB(255, 153, 204)   'Lt Red
                Case vbFriday: TodaysColor = RGB(204, 153, 255)     'Lt Purple
                Case vbSaturday: TodaysColor = RGB(255, 204, 153)   'Lt Orange
            End Select
            With Target
                If .Value <> vTargVal Then
                    .Interior.Color = TodaysColor
                    Range("A" & .Row).Interior.Color = RGB(255, 255, 0)
                    Range("C" & .Row).Interior.Color = TodaysColor
                End If
            End With
        End If
    End If
End Sub

I am using this to keep track of date changes in our weekly tracker. Is there a way to modify this code to include creating a named range so that every time a cell is changed it 1. changes colors and 2. gets added to a named range (I.g. The named range would be based on the day the changed occurred Monday, Tuesday, etc...) I then could use those named ranges to add the pattern style to those cells (I think this would significantly faster than looping through all cells). I currently have a sub that sends the colored sheet with updates via Outlook to the appropriate team members that update our master tracker. I would like to use the code to add the pattern style to the cells that have already have been changed after they have been sent in to be updated. The idea is two fold, 1. the user making the updates can see which one were sent in to the person updating the Master New vs old and 2. for the person updating the master tracker to differentiate the old vs the new updates.

I hope this makes sense to someone out there

Thanks in advanced
Alex

**billstpierre79** · 07-06-2013, 12:44 AM

Try this

Sub REcolorer()
Application.ScreenUpdating = False
    Dim cl As Range
    Dim active_rng As Range
        Set active_rng = Range("A2:A1200")
        For Each cl In active_rng
        Application.StatusBar = "Running Macro"
            If cl.Interior.Color = RGB(204, 255, 255) Or _
            (cl.Interior.Color = RGB(204, 255, 204)) Or _
            (cl.Interior.Color = RGB(255, 255, 153)) Or _
            (cl.Interior.Color = RGB(153, 204, 255)) Or _
            (cl.Interior.Color = RGB(255, 153, 204)) Or _
            (cl.Interior.Color = RGB(204, 153, 255)) Or _
            (cl.Interior.Color = RGB(255, 204, 153)) Then
                With cl.Interior
                .Pattern = xlGray8
                .PatternThemeColor = xlThemeColorDark1
                .TintAndShade = 0
                .PatternTintAndShade = -0.499984740745262
                End With
            End If
        Next cl
    
    Set active_rng = Range("C2:C1200")
        For Each cl In active_rng
        Application.StatusBar = "Running Macro"
            If cl.Interior.Color = RGB(204, 255, 255) Or _
            (cl.Interior.Color = RGB(204, 255, 204)) Or _
            (cl.Interior.Color = RGB(255, 255, 153)) Or _
            (cl.Interior.Color = RGB(153, 204, 255)) Or _
            (cl.Interior.Color = RGB(255, 153, 204)) Or _
            (cl.Interior.Color = RGB(204, 153, 255)) Or _
            (cl.Interior.Color = RGB(255, 204, 153)) Then
                With cl.Interior
                .Pattern = xlGray8
                .PatternThemeColor = xlThemeColorDark1
                .TintAndShade = 0
                .PatternTintAndShade = -0.499984740745262
                End With
            End If
        Next cl
        
        Application.StatusBar = False
End Sub

**AlphaFrog** · 07-06-2013, 01:00 AM

Another one.

Sub REcolorer()
    
    Dim arrColors(1 To 7) As Long
    Dim cl As Range, cl2 As Range
    
    arrColors(1) = RGB(204, 255, 255) 'Turquoise
    arrColors(2) = RGB(204, 255, 204) 'Lt Green
    arrColors(3) = RGB(255, 255, 153) 'Lt Yellow
    arrColors(4) = RGB(153, 204, 255) 'Lt Blue
    arrColors(5) = RGB(255, 153, 204) 'Lt Red
    arrColors(6) = RGB(204, 153, 255) 'Lt Purple
    arrColors(7) = RGB(255, 204, 153) 'Lt Orange
    
    Application.ScreenUpdating = False
    For Each cl In Range("A2:A" & Cells.Find("*", , , , 1, 2).Row)
        If IsNumeric(Application.Match(cl.Interior.Color, arrColors, 0)) Then
            For Each cl2 In Range(cl, Cells(cl.Row, Columns.Count).End(xlToLeft))
                If IsNumeric(Application.Match(cl2.Interior.Color, arrColors, 0)) Then
                    With cl2.Interior
                        .Pattern = xlGray8
                        .PatternThemeColor = xlThemeColorDark1
                        .TintAndShade = 0
                        .PatternTintAndShade = -0.499984740745262
                    End With
                End If
            Next cl2
        End If
    Next cl
    Application.ScreenUpdating = True
    
End Sub

**arleutwyler** · 07-06-2013, 01:17 AM

Thanks Again AlphaFrog!! you've come through again!!! this is super fast

**arleutwyler** · 07-06-2013, 01:07 AM

I see what you are doing with splitting the range but I need it to included A2-MM1200. I think trying to add the cell that change to a named range will still run faster then running through all of those cells. Any advice on how I could use the code I posted to do what I was talking about?

thanks again

**jindon** · 07-06-2013, 01:49 AM

How about

Sub test()
    Dim colr, e
    colr = Array(RGB(204, 255, 255), RGB(204, 255, 204) _
            , RGB(255, 255, 153), RGB(153, 204, 255), _
            RGB(255, 153, 204), RGB(204, 153, 255), RGB(255, 204, 153))
    For Each e In colr
        With Application.FindFormat
            .Clear
            .Interior.Color = e
        End With
        With Application.ReplaceFormat
            .Clear
            With .Interior
                .Pattern = xlGray8
                .PatternThemeColor = xlThemeColorDark1
                .TintAndShade = 0
                .PatternTintAndShade = -0.499984740745262
            End With
        End With
        Range("A2:MM1200").Replace What:="", Replacement:="", _
            SearchFormat:=True, ReplaceFormat:=True
    Next
End Sub

Help Speed up this Loop?!?

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Help Speed up this Loop?!?

Re: Help Speed up this Loop?!?

Re: Help Speed up this Loop?!?

Re: Help Speed up this Loop?!?

Re: Help Speed up this Loop?!?

Re: Help Speed up this Loop?!?

Re: Help Speed up this Loop?!?

Re: Help Speed up this Loop?!?

Re: Help Speed up this Loop?!?

Re: Help Speed up this Loop?!?

Thread Information

Users Browsing this Thread

Bookmarks

Bookmarks

Posting Permissions