Run the code faster

B

baha17

Board Regular
Joined
May 12, 2010
Messages
181
Hi Everyone,

Below code runs in sec.Is there any way to run it faster? Any magical touch from you experts?
Thank you for the help.

Baha

Code: 
Sub ColorMeUp()
Dim cel As Range
Dim LastRow, LastRow2 As Long
Dim sht As Worksheet
Dim FindId As Range
Application.ScreenUpdating = False
For Each sht In Worksheets
Select Case sht.Name
Case Is = Range("ActiveRoster").Text '"MorningFloorMap", "SwingFloorMap", "GraveFloorMap"
    LastRow = sht.Range("A65536").End(xlUp).Row
    LastRow2 = Sheets("ColorCode").Range("A65536").End(xlUp).Row
' FOR THE MAIN DEALERS
For Each cel In sht.Range("D2:D" & LastRow)
On Error Resume Next
    If cel.Value <> 0 Or cel <> "" Then
    With Sheets("ColorCode").Range("A2:A" & LastRow2)
    Set FindId = .Find(What:=cel.Value, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
    If Not FindId Is Nothing Then
    If FindId.Offset(0, 1) = True Then
    With cel.Interior
        .ColorIndex = 6
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    With cel.Offset(0, 1).Interior
        .ColorIndex = 6
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    End If
   
    If FindId.Offset(0, 2) = True Then
    With cel.Font
        .FontStyle = "Bold"
        .Color = 255
    End With
    With cel.Offset(0, 1).Font
        .FontStyle = "Bold"
        .Color = 255
    End With
    Else
        With cel.Font
        .FontStyle = "Bold"
        .Color = 8
    End With
    With cel.Offset(0, 1).Font
        .FontStyle = "Bold"
        .Color = 8
    End With
    
    End If
    End If
    End With
    End If
Next cel
'FOR THE DEALER SWING
For Each cel In sht.Range("H2:H" & LastRow)
On Error Resume Next
    If cel.Value <> 0 Or cel <> "" Then
    With Sheets("ColorCode").Range("A2:A" & LastRow2)
    Set FindId = .Find(What:=cel.Value, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
    
    If Not FindId Is Nothing Then
    If FindId.Offset(0, 1) = True Then
    With cel.Interior
        .ColorIndex = 6
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    With cel.Offset(0, 1).Interior
        .ColorIndex = 6
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    End If
    If FindId.Offset(0, 2) = True Then
    With cel.Font
        .FontStyle = "Bold"
        .Color = 255
    End With
    With cel.Offset(0, 1).Font
        .FontStyle = "Bold"
        .Color = 255
    End With
    Else
        With cel.Font
        .FontStyle = "Bold"
        .Color = 8
    End With
    With cel.Offset(0, 1).Font
        .FontStyle = "Bold"
        .Color = 8
    End With
    End If
    End If
    End With
    End If
Next cel
'FOR THE SUPERVISORS
For Each cel In sht.Range("L2:L" & LastRow)
On Error Resume Next
    If cel.Value <> 0 Or cel <> "" Then
    With Sheets("ColorCode").Range("A2:A" & LastRow2)
    Set FindId = .Find(What:=cel.Value, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
       
    If Not FindId Is Nothing Then
    If FindId.Offset(0, 1) = True Then
    With cel.Interior
        .ColorIndex = 6
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    With cel.Offset(0, 1).Interior
        .ColorIndex = 6
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    End If
    If FindId.Offset(0, 2) = True Then
    With cel.Font
        .FontStyle = "Bold"
        .Color = 255
    End With
    With cel.Offset(0, 1).Font
        .FontStyle = "Bold"
        .Color = 255
    End With
    Else
        With cel.Font
        .FontStyle = "Bold"
        .Color = 8
    End With
    With cel.Offset(0, 1).Font
        .FontStyle = "Bold"
        .Color = 8
    End With
    End If
    End If
    End With
    End If
    
Next cel
'FOR SWING SUPERVISORS
For Each cel In sht.Range("P2:P" & LastRow)
On Error Resume Next
    If cel.Value <> 0 Or cel <> "" Then
    With Sheets("ColorCode").Range("A2:A" & LastRow2)
    Set FindId = .Find(What:=cel.Value, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
    If Not FindId Is Nothing Then
    If FindId.Offset(0, 1) = True Then
    With cel.Interior
        .ColorIndex = 6
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    With cel.Offset(0, 1).Interior
        .ColorIndex = 6
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    End If
    If FindId.Offset(0, 2) = True Then
    With cel.Font
        .FontStyle = "Bold"
        .Color = 255
    End With
    With cel.Offset(0, 1).Font
        .FontStyle = "Bold"
        .Color = 255
    End With
    Else
        With cel.Font
        .FontStyle = "Bold"
        .Color = 8
    End With
    With cel.Offset(0, 1).Font
        .FontStyle = "Bold"
        .Color = 8
    End With
    End If
    End If
    End With
    End If
Next cel
Case Is = "Spares"
    LastRow = sht.Range("A65536").End(xlUp).Row
    LastRow2 = Sheets("ColorCode").Range("A65536").End(xlUp).Row
' FOR THE MAIN DEALERS
For Each cel In sht.Range("C2:C" & LastRow)
On Error Resume Next
    If cel.Value <> 0 Or cel <> "" Then
    With Sheets("ColorCode").Range("A2:A" & LastRow2)
    Set FindId = .Find(What:=cel.Value, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
    If Not FindId Is Nothing Then
    If FindId.Offset(0, 1) = True Then
    With cel.Interior
        .ColorIndex = 6
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    With cel.Offset(0, 1).Interior
        .ColorIndex = 6
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
    End With
    End If
   
    If FindId.Offset(0, 2) = True Then
    With cel.Font
        .FontStyle = "Bold"
        .Color = 8
    End With
    With cel.Offset(0, 1).Font
        .FontStyle = "Bold"
        .Color = 8
    End With
    Else
        With cel.Font
        .FontStyle = "Bold"
        .Color = 8
    End With
    With cel.Offset(0, 1).Font
        .FontStyle = "Bold"
        .Color = 8
    End With
    
    End If
    End If
    End With
    End If
Next cel
End Select
Next sht
HighlightingShifts
End Sub
 

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
Sort by date Sort by votes
A code is a code. If it runs properly then its fine. I don't think there is a way to make it smaller >_<
 
Upvote 0
epuron,thank you very much for your bright answer.Unfortunately,i am not searching for lecture in philosophy, just looking for a possible solution to my problem.if you're not interested to solve,simply do not input...
 
Upvote 0
It looks like AutoFilter along with xlCellTypeVisible could be used here: I believe theat would be faster, but would require re-write.
 
Upvote 0
Not home to post any code but the formatting code could be shortened using resize rather than offset (I doubt if it would make it any faster though)
 
Upvote 0
Mark thank you, looks like runs half sec faster. i just replaced all offset with resize.
tweedle can you give an example?
by the way this file saved as excel 2003, but all the computers rus it with excel 2007. do you think it would be better if i save the file in 2007?
the reason i am trying to run the code faster.it combined with other codes that export data from access files using "ADO" and it all added up running slowly.especially if the server reponse slower code runs all in all 30 sec which is killing the users.
thanks for your inputs
cheers
Baha
 
Upvote 0
baha17 said:
Mark thank you, looks like runs half sec faster. i just replaced all offset with resize.
tweedle can you give an example?
by the way this file saved as excel 2003, but all the computers rus it with excel 2007. do you think it would be better if i save the file in 2007?
the reason i am trying to run the code faster.it combined with other codes that export data from access files using "ADO" and it all added up running slowly.especially if the server reponse slower code runs all in all 30 sec which is killing the users.
thanks for your inputs
cheers
Baha
Click to expand...

RE: Example: Yes - Give me few minutes.

RE: code runs all in all 30 sec which is killing the users
Take it away from them for a day and have them manually calc it, then ask them how long 30 secs is.
 
Upvote 0
OK, below is what I came away with in slightly more than a few minutes.
This is only for the ActiveRoster sheet in the Case statement.
The same theory would apply to each though.

Code: 
Sub ColorMeUp2()


    Dim cel As Range
    Dim LastRow, LastRow2 As Long
    Dim sht As Worksheet
    
    Dim rngWorkRange As Range, rngWorkRangeFiltered As Range, rngColorMap As Range
    


    Application.ScreenUpdating = False


    LastRow2 = Sheets("ColorCode").Range("A65536").End(xlUp).Row
    Set rngColorMap = Sheets("ColorCode").Range("A1:B" & LastRow2)


    For Each sht In Worksheets
        Select Case sht.Name
            Case Is = Range("ActiveRoster").Text    '"MorningFloorMap", "SwingFloorMap", "GraveFloorMap"
                LastRow = sht.Range("A65536").End(xlUp).Row

                sht.Activate

                'Set a working Range
                Set rngWorkRange = Range("A1:L" & LastRow) ' UPDATE AS Needed: I have sample data set to Column L
                'Filter the working range
                rngWorkRange.AutoFilter Field:=4, Criteria1:=Array("<>", ">0"), Operator:=xlAnd
                'Set newRange From Filtered areas
                Set rngWorkRangeFiltered = rngWorkRange.Columns(4).SpecialCells(xlCellTypeVisible).Cells
                
                'Loop through cells; no real way around this I see at the moment
                For Each cel In rngWorkRangeFiltered
                    'Look up the color scheme setting True|False for value
                    'Could probably do better than a WorksheetFunction here
                    On Error Resume Next 'Error Trap any vlookups that fail
                    retval = WorksheetFunction.VLookup(cel.Value, rngColorMap, 2, False)
                    On Error GoTo 0


                    'If vlookup success and value is True, then
                    If retval = True Then
                        'Do Coloring
                        With cel.Resize(1, 2).Interior
                            .ColorIndex = 6
                            .Pattern = xlSolid
                            .PatternColorIndex = xlAutomatic
                        End With
                    End If
                Next    'Cel


                'Reset
                rngWorkRange.Worksheet.AutoFilterMode = False
                Set rngWorkRangeFiltered = Nothing
                Set rngWorkRange = Nothing


        End Select
    Next    'Sheet


Application.ScreenUpdating = True
End Sub

HTH
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

stephicohu
  • Question
Unconditional Formatting variable
Replies
3
Views
212
James006
James006
J
  • Question
Color fill cells surrounding shapes
Replies
9
Views
161
julhs
J
D
  • Question
VBA code works when called directly, but not from another routhine
Replies
7
Views
178
davidepstein22
D
H
  • Question
Vba Macro Code running partially when i trying it from another worksheet
Replies
3
Views
422
HaHoBe
HaHoBe
Nlhicks
  • Solved
Color the Changed Line from A to AL with solid interior color 34
Replies
7
Views
186
Micron
M

Forum statistics

Threads
1,202,976
Messages
6,052,873
Members
444,606
Latest member
rwmhr

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