0

I need to search two tables which change daily for certain values, then highlight the corresponding cells in grey and write the thresholds in the first column of each table.

For this I am using the following approach which works as intended.
Unfortunately, the macro needs more than one minute to complete this which to me seems very long for such an action (and this macro is only part of a larger one).

Both tables are relatively small and only contain approx. 500 resp. 100 records.

Can someone tell me how I can make this run faster or write this code more efficient ?

My code:

Sub PrepareRankRecords(varMode As String) Call RankRecords(varMode, 10000) Call RankRecords(varMode, 5000) Call RankRecords(varMode, 2000) Call RankRecords(varMode, 1500) Call RankRecords(varMode, 1000) Call RankRecords(varMode, 500) End Sub Sub RankRecords(varMode As String, varRank As Integer) Dim cell As Range, varRange As Range If varMode = "DSP" Then ' table AE:AJ Application.StatusBar = "90 % - Ranking table AE:AJ" DoEvents Set varRange = Range("$AI$3", Cells(Rows.Count, "AI").End(xlUp)).Cells Else ' table X:AC Application.StatusBar = "60 % - Ranking table X:AC" DoEvents Set varRange = Range("$AB$3", Cells(Rows.Count, "AB").End(xlUp)).Cells End If With Worksheets(4) For Each cell In varRange If cell.Offset(0, -3).Value <> "" Then If cell.Value < varRank Then cell.Offset(0, -4).Value = "< " & Format(varRank, "#,##0") .Range(Cells(cell.Row, cell.Column - 4), Cells(cell.Row, cell.Column + 1)). _ Interior.Color = RGB(217, 217, 217) .Range(Cells(cell.Row, cell.Column - 4), Cells(cell.Row, cell.Column + 1)). _ Font.Bold = True Exit For End If Else Exit For End If Next End With End Sub

Many thanks in advance for any help with this, Mike

Improve this question
1
  • 1
    Put your data to an array and do all the heavy lfting there and then write back to the spreadsheet. Commented May 9, 2017 at 16:48

2 Answers 2

Reset to default
1

Usually what I would do is the following:

Sub PrepareRankRecords(varMode As String) call Onstart Call RankRecords(varMode, 10000) Call RankRecords(varMode, 5000) 'other code call OnEnd End Sub Public Sub OnEnd() Application.ScreenUpdating = True Application.EnableEvents = True Application.AskToUpdateLinks = True Application.DisplayAlerts = True Application.Calculation = xlAutomatic ThisWorkbook.Date1904 = False Application.StatusBar = False End Sub Public Sub OnStart() Application.ScreenUpdating = False Application.EnableEvents = False Application.AskToUpdateLinks = False Application.DisplayAlerts = False Application.Calculation = xlAutomatic ThisWorkbook.Date1904 = False ActiveWindow.View = xlNormalView End Sub

You may inspect the OnStart/OnEnd and remove the parts that you consider useless.

Improve this answer
Sign up to request clarification or add additional context in comments.

6 Comments

Thanks, Vityata. I like this approach (some of it I already had, just not copied here). :)
I tested this and it works great (first time the calculation needs to be changed to Manual I assume. ;) ). Just one question: When I switch off the screen updating I cant show the progress on the status bar anymore, right ?
@keewee279 - Manual is quite dangerous, I never use it. But it would be slightly faster.
Thanks but then you set it to Automatic both on start and on end ?
@keewee279 - just to make sure... One is never 100% sure. E.g., somewhere in the middle of the code you can change it to Manual and then suffer a lot, if you do not change it back.
|
0

I would replace Cells(cell.Row, cell.Column - 4) with cell(1, -3).

Also I would replace consecutive calling of RankRecords with using Select Case inside your main loop to do all things in one pass.

Improve this answer

3 Comments

Thanks, avb. This is not what I need as my rows change dynamically and I need all cases, not just one of them. :)
But, if I understand this well it would be possible not to lose anything and do it in one pass
I would be happy to but dont see a way for it and case wouldnt work here as all cases will apply all the time and I dont want to duplicate code.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.