Macro very intensive and slow- can I make it shorter and therefore quicker?

[twinkle99]

I have a procedure which loops through a worksheet and performs count statements. These counts are performed in Sheet3 (this is where all the data is), the dates used in each statement is taken from Sheet2, the counts are then written back to Sheet1.

The problem I have is that the procedure is very large and it is quite repetitive so I was wondering how I could make it shorter and therefore run quicker.

below is 1/10th of the total procedure, basically, the next batch of loop statements (i.e. For Each c in rng) use Today1 and then Today2 and so on until Today9. There are 10 codes in each batch, so basically 100 'For Each c In rng' statements are used in the entire procedure.

Any help with this is appreciated. Please note, the data will not always reach row 10,000 as defined in the rng i.e. it might only reach row 6000 so i dont know if it is slow because the procedure is looking at empty rows?

Thanks

Sub test()

Application.ScreenUpdating = False
Dim today As Date, today1 As Date, today2 As Date, today3 As Date, today4 As Date, today5 As Date, today6 As Date, today7 As Date, today8 As Date, today9 As Date, today10 As Date
today = Sheets("Sheet2").Range("F9")
today1 = Sheets("Sheet2").Range("F10")
today2 = Sheets("Sheet2").Range("F11")
today3 = Sheets("Sheet2").Range("F12")
today4 = Sheets("Sheet2").Range("F13")
today5 = Sheets("Sheet2").Range("F14")
today6 = Sheets("Sheet2").Range("F15")
today7 = Sheets("Sheet2").Range("F16")
today8 = Sheets("Sheet2").Range("F17")
today9 = Sheets("Sheet2").Range("F18")
today10 = Sheets("Sheet2").Range("F19")

Dim rng As Range, c As Range
Dim countda, countdb, countdc, countdd, countde, countdf, countdg, countdh, countdi, countdj As Long

countda = 0
countdb = 0
countdc = 0
countdd = 0
countde = 0
countdf = 0
countdg = 0
countdh = 0
countdi = 0
countdj = 0

Sheets("Sheet3").Select

Set rng = Range("A1:G10000")

For Each c In rng
If c.Offset(0, 4) = "CODE1" And c.Offset(0, 5) = "" And c.Offset(0, 2) = today Then countda = countda + 1
Next c

For Each c In rng
If c.Offset(0, 4) = "CODE2" And c.Offset(0, 5) = "" And c.Offset(0, 2) = today Then countdb = countdb + 1
Next c

For Each c In rng
If c.Offset(0, 4) = "CODE3" And c.Offset(0, 5) = "" And c.Offset(0, 2) = today Then countdc = countdc + 1
Next c

For Each c In rng
If c.Offset(0, 4) = "CODE4" And c.Offset(0, 5) = "" And c.Offset(0, 2) = today Then countdd = countdd + 1
Next c

For Each c In rng
If c.Offset(0, 4) = "CODE5" And c.Offset(0, 5) = "" And c.Offset(0, 2) = today Then countde = countde + 1
Next c

For Each c In rng
If c.Offset(0, 4) = "CODE6" And c.Offset(0, 5) = "" And c.Offset(0, 2) = today Then countdf = countdf + 1
Next c

For Each c In rng
If c.Offset(0, 4) = "CODE7" And c.Offset(0, 5) = "" And c.Offset(0, 2) = today Then countdg = countdg + 1
Next c

For Each c In rng
If c.Offset(0, 4) = "CODE8" And c.Offset(0, 5) = "" And c.Offset(0, 2) = today Then countdh = countdh + 1
Next c

For Each c In rng
If c.Offset(0, 4) = "CODE9" And c.Offset(0, 5) = "" And c.Offset(0, 2) = today Then countdi = countdi + 1
Next c

For Each c In rng
If c.Offset(0, 4) = "CODE10" And c.Offset(0, 5) = "" And c.Offset(0, 2) = today Then countdj = countdj + 1
Next c

Sheets("Sheet1").Select

[F11] = countda
[F12] = countdb
[F13] = countdc
[F14] = countdd
[F15] = countde
[F16] = countdf
[F17] = countdg
[F18] = countdh
[F19] = countdi
[F20] = countdj


End Sub

 

[westconn1]

you could shorten the code a lot by using variable arrays to store your data, so you can use loops to fill variables more, but this possibly will not help speed

a possible speed saving is you use for each c in rng a number of times, when you should be able to all in one loop

Set rng = Range("A1:G10000")
                
        For Each c In rng
        If c.Offset(0, 4) = "CODE1" And c.Offset(0, 5) = "" And c.Offset(0, 2) = today Then countda = countda + 1
        If c.Offset(0, 4) = "CODE2" And c.Offset(0, 5) = "" And c.Offset(0, 2) = today Then countdb = countdb + 1
        If c.Offset(0, 4) = "CODE3" And c.Offset(0, 5) = "" And c.Offset(0, 2) = today Then countdc = countdc + 1
        If c.Offset(0, 4) = "CODE4" And c.Offset(0, 5) = "" And c.Offset(0, 2) = today Then countdd = countdd + 1
        If c.Offset(0, 4) = "CODE5" And c.Offset(0, 5) = "" And c.Offset(0, 2) = today Then countde = countde + 1
        If c.Offset(0, 4) = "CODE6" And c.Offset(0, 5) = "" And c.Offset(0, 2) = today Then countdf = countdf + 1
        If c.Offset(0, 4) = "CODE7" And c.Offset(0, 5) = "" And c.Offset(0, 2) = today Then countdg = countdg + 1
        If c.Offset(0, 4) = "CODE8" And c.Offset(0, 5) = "" And c.Offset(0, 2) = today Then countdh = countdh + 1
        If c.Offset(0, 4) = "CODE9" And c.Offset(0, 5) = "" And c.Offset(0, 2) = today Then countdi = countdi + 1
        If c.Offset(0, 4) = "CODE10" And c.Offset(0, 5) = "" And c.Offset(0, 2) = today Then countdj = countdj + 1
        Next c

should produce the same result, unless i am missing something, while each iteration of the loop would do more, this would save 90,000 loops
also do you need to loop through all the columns, just the column -4 from where code# is stored, this would cut down a further 9000 loops

for your information

Dim rng As Range, c As Range
Dim countda, countdb, countdc, countdd, countde, countdf, countdg, countdh, countdi, countdj As Long

while rng and c are correctly declared as ranges
only countdj is declared as a long, all the other count variables default to variant

 

[Gary McMaster]

Try going through "Rng" only once.

The first thing that comes to mind is "Select Case"

Something like this:

For Each c In Rng
Select Case c.Offset(0, 4)

Case "CODE1"
If c.Offset(0, 5) = "" And c.Offset(0, 2) = today Then countda = countda + 1
Case "CODE2"
If c.Offset(0, 5) = "" And c.Offset(0, 2) = today Then countdb = countdb + 1
Case "CODE3"
'As many case statments as you need

Case Else
'Process some exception like empty cells (no "CODEx"
End Select

Next c

I hope it helps.

Gary

 

[Krishnakumar]

Hi,

Create a backup of your file and test this code.

Sub kTest()
Dim Dats, Dts(1 To 11) As String, a, i As Long, x, w(), r(), s, n As Long

Dats = Sheets("Sheet2").Range("F9:f19")

For i = 1 To UBound(Dats, 1)
    Dts(i) = CStr(Dats(i, 1))
Next

With Sheets("Sheet3")
    a = .Range("A1:G" & .Range("a" & Rows.Count).End(xlUp).Row)
End With

ReDim w(1 To UBound(a, 1), 1 To 3)
With CreateObject("scripting.dictionary")
    .comparemode = vbTextCompare
    For i = 1 To UBound(a, 1)
        If IsEmpty(a(i, 6)) Then
            x = Application.Match(CStr(a(i, 3)), Dts, 0)
            If Not IsError(x) Then
                s = a(i, 5) & ";" & a(i, 3)
                If Not .exists(s) Then
                    n = n + 1
                    w(n, 1) = a(i, 5): w(n, 2) = a(i, 3): w(n, 3) = 1
                    .Add s, Array(n, 3)
                Else
                    r = .Item(s)
                    w(r(0), 3) = w(r(0), 3) + 1
                    .Item(s) = r
                End If
            End If
        End If
    Next
End With
With Sheets("Sheet1").Range("f10")
    .Resize(, 3).Value = Array("Code", "Date", "Count")
    .Offset(1).Resize(n, 3).Value = w
End With
End Sub

 

[twinkle99]

Thanks guys

The data in sheet3 will vary, can i set the rng so that it only goes to the last row which contains data rather than A1:G10000

lastrow = Sheets("Sheet3").UsedRange.Rows.Count
Set rng = Sheets("Sheet3").Range("A1:G" & lastrow)

Will this work?

 

[tusharm]

Based on the code snippet below, the data layout is rather unclear. Can you show a sample? Say, the data in A1:G10?

Set rng = Range("A1:G10000")

For Each c In rng
    If c.Offset(0, 4) = "CODE1" And c.Offset(0, 5) = "" And c.Offset(0, 2) = today Then countda = countda + 1
    Next c

 

[Gary McMaster]

Will this work?

Yes and no.

I find that the "UsedRange" can be unreliable, depending on the circumstances. "UsedRange" will report rows or columns that have had some kind of formatting applied even if they are now void of data.

If you can gaurantee that rows or columns that have been used previously have been deleted, or completely cleared of all formatting, then I find "UsedRange" works OK.

Gary

 

[Gary McMaster]

Below is a function I found on the Web, probably Mr. Excel. It seems to work even when subjected to the conditions I mentioned in my last reply.

Function LastCell(ws As Worksheet) As Range
 
'Identifying the Real Last Cell
'By: Rodney Powell
'Microsoft MVP - Excel
'http://www.beyondtechnology.com/geeks012.shtml
Dim LastRow&, LastCol%
'Error-handling is here in case there is not any
'data in the worksheet
On Error Resume Next
With ws
    'Find the last real row
    
    LastRow& = .Cells.Find(What:="*", _
        SearchDirection:=xlPrevious, _
        SearchOrder:=xlByRows).Row
    
    'Find the last real column
    
    LastCol% = .Cells.Find(What:="*", _
      SearchDirection:=xlPrevious, _
      SearchOrder:=xlByColumns).Column
End With
' Finally, initialize a Range object variable for
' the last populated row.
Set LastCell = ws.Cells(LastRow&, LastCol%)
 
End Function

 

[mikerickson]

It looks like you are using loops to replace a spreadsheet formula, perhaps an approach like this would be faster.

Dim prefixString As String, midfixString As String, postfixString As String

With rng
    prefixString = "SUMPRODUCT(--(" & .Offset(0, 4).Address(, , , True) & "=" & Chr(34)
    
    midfixString = Chr(34) & "),--(" & .Offset(0, 5).Address(, , , True) & "="""")"
    midfixString = midfixString & ",--(" & .Offset(0, 6).Address(, , , True) & "="
    
    postfixString = "))"
End With

countDA = Evaluate(prefixString & "Code1" & midfixString & "Sheet2!$F$9" & postfixString)
countDB = Evaluate(prefixString & "Code2" & midfixString & "Sheet2!$F$9" & postfixString)