PDA

View Full Version : Consolidating Multiple With Statements to Run Faster



mexmike
07-18-2015, 11:52 AM
Hello All,

I was wondering if someone could help to reduce or condense the following code so that it runs faster. Basically certain cells get bold font with a specific colour depending on certain criteria.

Many thanks in advance:anyone:


Public Sub SetColors(sht As Worksheet, Cel As Range) 'Ver 18 July 2015
Dim TimePriority As Long
Dim TimeColor As Long
Dim DatePriority As Long
Dim DateColor As Long
Dim TaskColor As Long
Dim TaskPriority As Long
Dim Rw As Long
Dim i As Long

Application.ScreenUpdating = False
With sht
Rw = Cel.Row
TimePriority = PriorityHours(Cells(Rw, HoursRemainingCol))
DatePriority = PriorityDays(Cells(Rw, DaysRemainingCol))

TimeColor = ColorByPriority(TimePriority)
DateColor = ColorByPriority(DatePriority)
TaskColor = TimeColor

If TimePriority < DatePriority Then TaskColor = DateColor

With .Cells(Rw, TaskCol).Font
.Color = TaskColor
.Bold = False

If TimePriority >= Priority4 Then .Bold = True
If DatePriority >= Priority4 Then .Bold = True

End With

With .Cells(Rw, HoursRemainingCol).Font
.Color = TaskColor
.Bold = False

If TimePriority >= Priority4 Then .Bold = True
If DatePriority >= Priority4 Then .Bold = True
End With

With .Cells(Rw, HoursDueCol).Font
.Color = TaskColor
.Bold = False

If TimePriority >= Priority4 Then .Bold = True
If DatePriority >= Priority4 Then .Bold = True
End With

With .Cells(Rw, DaysRemainingCol).Font
.Color = TaskColor
.Bold = False

If TimePriority >= Priority4 Then .Bold = True
If DatePriority >= Priority4 Then .Bold = True
End With

With .Cells(Rw, DateDueCol).Font
.Color = TaskColor
.Bold = False

If TimePriority >= Priority4 Then .Bold = True
If DatePriority >= Priority4 Then .Bold = True
End With



.Cells(Rw, BLankCol1).Interior.Color = TaskColor 'Adjust to suit


ColoredHoursCells = Array("G", "I")
For i = LBound(ColoredHoursCells) To UBound(ColoredHoursCells)
.Rows(Rw).Columns(ColoredHoursCells(i)).Font.Color = TimeColor


Next i

ColoredDaysCells = Array("N", "O")
For i = LBound(ColoredDaysCells) To UBound(ColoredDaysCells)
.Rows(Rw).Columns(ColoredDaysCells(i)).Font.Color = DateColor

Next i
End With
Application.ScreenUpdating = True
End Sub

mikerickson
07-18-2015, 12:00 PM
The easiest way to consolidate that code would be to make a single range range object


Dim myRange as Range
With sht

Rw = Cel.Row
TimePriority = PriorityHours(Cells(Rw, HoursRemainingCol))
DatePriority = PriorityDays(Cells(Rw, DaysRemainingCol))

TimeColor = ColorByPriority(TimePriority)
DateColor = ColorByPriority(DatePriority)
TaskColor = TimeColor

If TimePriority < DatePriority Then TaskColor = DateColor

Set myRange = Application.Union(.Cells(rw, TaskCol), .Cells(1, HourRemainingCol), .Cells(rw, HoursDueCol), .Cells(rw, DaysRemainingCol), .Cells(rw, DateDueCol))

With myRange.Font
.Color = TaskColor
.Bold = False

If TimePriority >= Priority4 Then .Bold = True
If DatePriority >= Priority4 Then .Bold = True
End With
End With

mexmike
07-18-2015, 12:16 PM
Great stuff and many thanks. I'm not quite sure how to incorporate your code into my code (SamT's really). I've cut out all of the repetitive "With" statements but keep getting errors with the remaining code.

Thanks again!

mexmike
07-18-2015, 12:31 PM
I've updated my code as below but get a Run time error '1004' "Application defined or object defined error" at
Set myRange = Application.Union(.Cells(Rw, TaskCol), .Cells(1, HourRemainingCol), .Cells(Rw, HoursDueCol), .Cells(Rw, DaysRemainingCol), .Cells(Rw, DateDueCol))

Public Sub SetColors(sht As Worksheet, Cel As Range) 'Ver 18 July 2015
Dim TimePriority As Long
Dim TimeColor As Long
Dim DatePriority As Long
Dim DateColor As Long
Dim TaskColor As Long
Dim TaskPriority As Long
Dim Rw As Long
Dim i As Long
Dim myRange As Range

Application.ScreenUpdating = False
With sht

Rw = Cel.Row
TimePriority = PriorityHours(Cells(Rw, HoursRemainingCol))
DatePriority = PriorityDays(Cells(Rw, DaysRemainingCol))

TimeColor = ColorByPriority(TimePriority)
DateColor = ColorByPriority(DatePriority)
TaskColor = TimeColor

If TimePriority < DatePriority Then TaskColor = DateColor

Set myRange = Application.Union(.Cells(Rw, TaskCol), .Cells(1, HourRemainingCol), .Cells(Rw, HoursDueCol), .Cells(Rw, DaysRemainingCol), .Cells(Rw, DateDueCol))

With myRange.Font
.Color = TaskColor
.Bold = False

If TimePriority >= Priority4 Then .Bold = True
If DatePriority >= Priority4 Then .Bold = True
End With


.Cells(Rw, BLankCol1).Interior.Color = TaskColor 'Adjust to suit


ColoredHoursCells = Array("G", "I")
For i = LBound(ColoredHoursCells) To UBound(ColoredHoursCells)
.Rows(Rw).Columns(ColoredHoursCells(i)).Font.Color = TimeColor


Next i

ColoredDaysCells = Array("N", "O")
For i = LBound(ColoredDaysCells) To UBound(ColoredDaysCells)
.Rows(Rw).Columns(ColoredDaysCells(i)).Font.Color = DateColor

Next i
End With
Application.ScreenUpdating = True
End Sub

mexmike
07-18-2015, 12:52 PM
Looks like it was just an "s" missing from "HourRemaining", changed to "HoursRemaining" and seems to work.

I'll do some time comparisons between the two versions and give feedback.

Many Thanks for your extremely fast assist:hi:

Paul_Hossler
07-18-2015, 01:48 PM
Looks like it was just an "s" missing from "HourRemaining", changed to "HoursRemaining" and seems to work.


Did you have Option Explicit at the top of the (each) module?

That requires all variables to be explicitly Dim-ed and helps catch typos like that

mexmike
07-18-2015, 02:09 PM
Couple of modules were missing the "Option Explicit" as did the one with the offending missing "s". I've now inserted them to all of my modules. Thanks.

Done a time check on the repaint and bold of an unformatted sheet. Not much difference really but the code is much cleaner.

If I decided to bold the entire row containing data (columns A to O), instead of individual cells in each column; would that be any faster? There are 139 rows, which require different colours and bold and not bold cells depending on their respective criteria. Basically all of the fonts from A to O would be bolded instead of individual cells. Might not attract the eye so much, which is the purpose of the bold and colour change, but speed is also of the premium.

Paul_Hossler
07-19-2015, 09:47 AM
1. can you post a small sample workbook?

2. As an unsolicited suggestion, I noticed that in



TimePriority = PriorityHours(Cells(Rw, HoursRemainingCol))
DatePriority = PriorityDays(Cells(Rw, DaysRemainingCol))



you didn't specifically reference a worksheet even though it was within a With block. It will assume the active sheet, what ever that is. You probably wanted it to always refer to sht so add the dot to Cells



TimePriority = PriorityHours(.Cells(Rw, HoursRemainingCol))
DatePriority = PriorityDays(.Cells(Rw, DaysRemainingCol))





Simple demo




Option Explicit
Sub Dots()
Dim r As Range
Worksheets("Sheet2").Select
Set r = Cells(1, 1)
MsgBox ActiveSheet.Name
MsgBox r.Address(1, 1, 1, 1)

Worksheets("Sheet1").Select
Set r = Cells(1, 1)
MsgBox ActiveSheet.Name
MsgBox r.Address(1, 1, 1, 1)

'with the dot
With Worksheets("Sheet2")
Set r = .Cells(1, 1)
End With
MsgBox ActiveSheet.Name
MsgBox r.Address(1, 1, 1, 1)

End Sub

mexmike
07-19-2015, 01:54 PM
Hi Paul,

Thanks for the input. Point taken regarding the ".Cells" code; now updated in my project.
Please see attached file. It is a sample project only and uses garbage data. My actual data file uses vba for sorting rows etc.

Basically its a vehicle maintenance tracker, driven by running hours and calendar time. SamT had been kindly assisting me with this, under the thread "[SOLVED] Colour Entire Row Base on the Value of Two Other Cells". SamT's been having some computer issues and recommended that I start a new thread in the meantime.

I'm at a point where things are coming together regarding the colour coding; which is to use VBA to highlight inspections in colour and to use bold font for those inspections close to expiration. Things are working but the vba code for colouring and bolding runs quite slowly. mikerickson has kindly helped me to clean up some of my redundant code with the view to achieving this.

Apart from wanting to speed up the colour coding and bolding, I'd like to have the entire Sheet including input columns "A", "C", "E", "L" and "M" locked. I'd like updating to require a "double click" or "tick in box" to unlock ONLY the input cells in that particular row/column that need to be updated post inspection i.e. doubleclick "E15" to unlock and update "hrs at Check" for the "Check Washer Level" on Sheet "CD311" (Take into consideration that normally all of my sheets are password protected and locked for editing except for the input columns "A", "C", "E", "L" and "M". I have a feeling it's not possible to have the entire sheet password protected and unlock only input cells as desired without losing formula security on the rest of the sheet. The idea is to prevent inadvertent modifications of cells containing formulas by the mechanic and also to protect my work (The uploaded sample project should not have protection by the way).

And that's where I am at present. Any help is kindly appreciated .

Note: Double clicking the "Hours to Next Check" on the "Main" Sheet and selecting a different cell runs the macro to update the colours and fonts. A message box pops up to indicate this (for testing purposes only).

Paul_Hossler
07-19-2015, 03:53 PM
What part runs slowly? ForceUpdateColors?

If you don't want ForceUpDateColors to run when the WB opens, why is it in the WB_Open event?

When is it supposed to be run? Manually or using some OnTime?





Public Sub ForceUpdateColors()
Dim s As Long
Dim VShts()
Dim sht As Worksheet
'This line is a deliberate error to prevent this code from running when the book is opened
'set time to run = Now + 1 hours as = 10 seconds after the hour
RunForceUptateColorsTime = Format(Now + TimeValue(DateAdd("h", 1, 0)), _
"m/d/yyyy H:00:00")

Application.OnTime EarliestTime:=TimeValue(RunForceUptateColorsTime), _
Procedure:="ForceUpdateColors"
MsgBox "Force Update is running"


'If SecondTime Then 'Disabled to allow update on WB open
VehicleSheets = Array("CD311", "CD456", "CD123", "CD678")
For s = LBound(VehicleSheets) To UBound(VehicleSheets)
Set sht = Sheets(VehicleSheets(s))
UpdateColors sht
Next s
'End If 'Disabled to allow update on WB open
'SecondTime = True 'Prevents updating colors on book open. 'Disabled to allow update on WB open
End Sub

mexmike
07-19-2015, 04:28 PM
That was code from SamT. He was not sure if I wanted to update on opening the WB but I did, so he showed me how to disable it.

If you doubleclick the Main sheet "Hours to Next Check" values and then select another cell, a MsgBox "Update Colors is running" pops up and all the cells in the sheet are updated. It only takes about 7 seconds to refresh the sample sheet after selecting the "OK" button. But that is the 'sample' data.

In my original workbook with live data (cannot post due to sensitive data), it takes about 16 seconds to refresh each sheet. When I open the workbook, all of the sheets update. it takes more than 30 seconds to refresh all the colours and bold the fonts that have changed status due to date change in 4 sheets. Thats the time I'm trying to reduce.

Paul_Hossler
07-20-2015, 09:18 AM
Did a lot of clean up. There's 3 subs: to update all sheets, update one sheet, update single row

Made sheet of notes

Look over the code -- marked some with "PHH' as flag

I think the logic is still right in terms of colors, but all sheets will color update in 2-3 seconds for me






Suggestions






1. Added title to vehicle sheets D10 to make .CurrentRegion work; Deleted empty Col H same reason






2. Veh sheets, row 10 I made row height more and vert align to so filters don't cover title






3. Made veh sheets B11 fixed pane to scroll better






4. Removed WS event handlers and made 'smarter one' (at least that's what I tell myself) in the ThisWorkbook






5. Made 'Main' event handlers a little smarter also






6. Big changes in modColor

mexmike
07-20-2015, 12:15 PM
Many Thanks Paul. I'll have a look after work today:thumb

mexmike
07-20-2015, 05:42 PM
Absolutely fantastic Paul:clap2::clap2::clap2:

I've integrated your code into my actual workbook and it took 5 seconds to update all of the colours and bold the fonts in all of the sheets, as opposed to 30 something plus seconds previously. I didn't think it was going to be possible. Really great work and many thanks!!!

I actually use macros for sorting, as all of my sheets are protected, so filtering is not really required. I had used Excel filtering on the test project to check the alignment of data.

One of the most important macros I use is the colour sort macro of column "D". This brings all of the priority hour and date items to the top of the sheet. Please see below. The macro works, but I'd really like to be able to order the data correctly within each colour band i.e. hours that are red in ascending order followed by days that are red in ascending order.

Option ExplicitSub MacroColorSort()


'Set up your variables and turn off screen updating.

ActiveSheet.Unprotect Password:="password"
Dim iCounter As Integer
Application.ScreenUpdating = False

'For each cell in column A, go through and place the color index value of the cell in column C.
For iCounter = 11 To 139
Cells(iCounter, "O") = _
Cells(iCounter, 4).Interior.ColorIndex

Next iCounter

Range("A11:N139").Select
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range("O11:O139"), CustomOrder:="3,45,50,5,1,-4142,2"

With ActiveSheet.Sort
.SetRange Range("A11:O139")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With


'Clear out the temporary sorting value in column C, and turn screen updating back on.
Columns("O").ClearContents

Range("D9").Select
Application.ScreenUpdating = True

ActiveSheet.Protect Password:="password"
End Sub


I had asked this question in the post ... 'Related to Thread: Colour Entire Row Base on the Value of Two Other Cells in Excel', that SamT had been helping me with,but got no replies. If that was possible, it would be the cherry on the cake. Is that a possibility?

Regardless, your great work has made my workbook so much more efficient as it is. Again, many many thanks.:yes

Paul_Hossler
07-20-2015, 06:50 PM
Look in modColoring -- you'll need to integrate the logic into your real workbook

In the Color Indictor column I just put in the 'task priority value' and made the font the task color







.Cells(Rw, IndCol).Interior.Color = TaskColor 'Adjust to suit
.Cells(Rw, IndCol).Value = iTaskPriority
.Cells(Rw, IndCol).Font.Color = TaskColor






Private Sub MacroColorSort(sht As Worksheet)
Dim iCounter As Integer
Dim s As Long
Dim rRow As Range, rData As Range, rSortData As Range
' sht.Unprotect Password:="password"
Set rData = sht.Range("A10").CurrentRegion
Set rSortData = rData.Cells(2, 1).Resize(rData.Rows.Count - 1, rData.Columns.Count).Columns(IndCol)


With sht.Sort
.SortFields.Clear
.SortFields.Add Key:=rSortData, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.SetRange rData
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

' sht.Protect Password:="password"
End Sub

mexmike
07-21-2015, 08:47 AM
Ok Paul will try that.

One problem I'm having is with my password protected sheets. Columns "M" and "N" are not updating in real time as I enter new data following the code change. The entire sheet update and entire workbook update works. I believe it's because of my sheet protection.

Could you let me know where I can insert the following code to unlock and lock the worksheets that will let the code run properly i.e.

ActiveSheet.Unprotect Password:="password" and ActiveSheet.Protect Password:="password"

Many Thanks

mexmike
07-21-2015, 09:45 AM
Paul,
Ignore my last. Missed out pasting part of the code from Private Sub Workbook_SheetChange

Sorry
:banghead::banghead::banghead:

mexmike
07-21-2015, 01:30 PM
Ok Paul, things are working great regarding the colour sorting!!! When the workbook opens everything is in order.

I'd also like to run the sorting from within each sheet after adding a Task to the list. Is there a way to assign the MacroColorSort to run the from a button? When I open the assign macro dialogue after putting a button on the sheet, the MacroColorSort routine does not appear in the list. I guess I'm missing something:dunno

Thanks

Paul_Hossler
07-21-2015, 02:16 PM
Remove the keyword Private to make the macro visible





Private Sub MacroColorSort(sht As Worksheet)

mexmike
07-21-2015, 02:26 PM
Tried that but the only macro that comes up in the list is ForceUpdateColorsAll

Paul_Hossler
07-21-2015, 02:58 PM
My bad .. I was too fast on the keyboard.

If the macro has parameters (like 'sht') it won't be directly run-able (I think there's a workaround, but it gets finicky, so I rarely use it)

So MacroColorSort can't be directly run since it requires a Worksheet object, but the new SortColorsOnActiveSheet can be assigned to a button or run via Alt-F8





Sub SortColorsOnActiveSheet()
Call MacroColorSort(ActiveSheet)
End Sub

Private Sub MacroColorSort(sht As Worksheet)

mexmike
07-21-2015, 03:03 PM
I put the code in a separate module but kept getting errors. Could only get round it as follows. Basically the color sort code is where you put it and also in a macro Sub
Obviously it would be neater to have only one set of code for the colour sorting.
MacroColorSort()

Sub MacroColorSort()
'Dim sht As Worksheet
Dim iCounter As Integer
Dim s As Long
Dim rRow As Range, rData As Range, rSortData As Range


' ActiveSheet.Unprotect Password:="password"

Set rData = ActiveSheet.Range("A10").CurrentRegion 'sht changed to ActiveSheet
Set rSortData = rData.Cells(2, 1).Resize(rData.Rows.Count - 1, rData.Columns.Count).Columns(IndCol)


With ActiveSheet.Sort 'sht changed to ActiveSheet
.SortFields.Clear
.SortFields.Add Key:=rSortData, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
.SetRange rData
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

' ActiveSheet.Protect Password:="password"
End Sub

mexmike
07-21-2015, 03:30 PM
It doesn't always sort accurately; as though there is a bit of randomness to it, but easily as good as my effort and way quicker. It usually corrects the order, if I order it, using one of the other column sorts first and then go back to the colour order.

mexmike
07-21-2015, 04:19 PM
Ok I'll give a go.

Hey! Many many thanks for your help.

Paul_Hossler
07-21-2015, 04:43 PM
It doesn't always sort accurately; as though there is a bit of randomness to it, but easily as good as my effort and way quicker. It usually corrects the order, if I order it, using one of the other column sorts first and then go back to the colour order.

You also could add another column to the .Sort in the color sort macro

mexmike
07-21-2015, 05:00 PM
Yeah! But really it's just fine as it is. The most important thing to me, is to view everything that's due by colour in a nice tight bunch. At the end of the day, everything has to get done. Thanks to you and SamT its a hell of a lot more visible and jumps out at you.:clap::clap::clap::clap::clap: