No announcement yet.

Speeding/Optimizing looping macro help

  • Filter
  • Time
  • Show
Clear All
new posts

  • Speeding/Optimizing looping macro help

    I have attached some sample data that gets updated daily and ends up being 70,000 plus rows after completion of the below code.

    The macro below essentially inserts rows for missing dates and copies values down to those rows. After all the rows are inserted the macro will then insert formulas into columns so that calculate max/min and week number for displaying later. This data is refreshed via SQL call every day and the code is then run to complete the missing data.

    Currently this macro takes 40 min to run and I have exhausted all of my knowledge on how to speed it up. I have read that it may be faster to use arrays and or variant to perform looping inserts like below but I just don't have any experience with this method and cant figure it out. Lastly I know there are some "Volatile" functions that should be avoided but I am not sure exactly how many I am using and how to avoid them. At this point I would be open to any ideas on how to speed this up.

    Thank you all for any ideas

    Sub FillDates()
    Dim StartRow, CurrRow, ct As Long
    Dim CurrDate, PrevDate, DateDiff As Long
    Dim CurrPriceID, PrevPriceID As Long
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    'Initialize row counters
        StartRow = 2
        CurrRow = StartRow
        Do While Range("A" & CurrRow).Value <> ""
            'Determine if this is the first row
            If CurrRow = StartRow Then
                CurrDate = Range("E" & CurrRow).Value
                CurrPriceID = Range("F" & CurrRow).Value
                PrevDate = Range("E" & CurrRow - 1).Value
                PrevPriceID = Range("F" & CurrRow - 1).Value
                DateDiff = CurrDate - PrevDate
                'Determine if you are still on the same PriceID
                If CurrPriceID = PrevPriceID Then
                   'Determine if the year starts on the second day or not, if not than make it start on the 2nd
                    If Year(Range("E" & CurrRow - 1).Value) < Year(Range("E" & CurrRow).Value) Then
                        If Month(Range("E" & CurrRow).Value) = 1 And Day(Range("E" & CurrRow)) > 2 Then
                        Rows(CurrRow & ":" & CurrRow + DateDiff - 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                        ct = 1
                            Do While ct < DateDiff
                                Range("A" & CurrRow & ":I" & CurrRow).Value = Range("A" & CurrRow - 1 & ":I" & CurrRow - 1).Value
                                Range("E" & CurrRow).Value = Range("E" & CurrRow - 1).Value + 1
                                ct = ct + 1
                                CurrRow = CurrRow + 1
                        End If
                        CurrDate = Range("E" & CurrRow).Value
                        PrevDate = Range("E" & CurrRow - 1).Value
                        DateDiff = CurrDate - PrevDate
                    End If
                    'Determine if there is a gap between the days. If the gap is less than 1 week, fill in the gap
                    If DateDiff > 1 And DateDiff < 7 Then
                        Rows(CurrRow).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                        Range("A" & CurrRow & ":I" & CurrRow).Value = Range("A" & CurrRow - 1 & ":I" & CurrRow - 1).Value
                        Range("E" & CurrRow).Value = Range("E" & CurrRow - 1).Value + 1
                    End If
                    If Range("E" & CurrRow).Value + 1 = Date Then
                        'creates place holder dates to hold max and min values for current year range
                        Do While Month(Range("E" & CurrRow).Value) > 1
                            Rows(CurrRow + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                            Range("A" & CurrRow + 1 & ":F" & CurrRow + 1).Value = Range("A" & CurrRow & ":F" & CurrRow).Value
                            Range("E" & CurrRow + 1).Value = Range("E" & CurrRow).Value + 1
                            CurrRow = CurrRow + 1
                        'to delete the january of next year line added at end of loop
                    End If
                End If
            End If
            CurrRow = CurrRow + 1
                'Force the year to be 2000 to ensure week numbers line up from year to year
                Range("B2").Formula = "=IfError(WEEKNUM(MONTH([@Date]) & ""/"" & DAY([@Date]) & ""/"" & YEAR(""1/1/2000"")),"""")"
                Range("B2").AutoFill Destination:=Range("B2" & ":B" & CurrRow)
                Range("H2").Formula = "=IfError(MINIFS([SettlePrice],[Week],[@Week],[Price ID],[@[Price ID]]),"""")"
                Range("H2").AutoFill Destination:=Range("H2" & ":H" & CurrRow)
                Range("I2").Formula = "=IfError(MAXIFS([SettlePrice],[Week],[@Week],[Price ID],[@[Price ID]]),"""")"
                Range("I2").AutoFill Destination:=Range("I2" & ":I" & CurrRow)
        Application.Calculation = xlCalculationManual
        Application.ScreenUpdating = True
        Application.DisplayStatusBar = True
        Application.DisplayAlerts = True
        Application.EnableEvents = True
    End Sub
    Attached Files

  • #2
    Sorry - this isn't likely to help you much, but I have had a look and can't see anything obvious that I would do differently....

    That said, when I run your FillDates macro on your attached file on my machine it takes something less than 30 seconds to complete... This is on an Intel Core i7 based laptop with 8Gb RAM running 64-bit Office 365... Perhaps a hardware upgrade is the solution?


    • #3
      Thank you Infomage,
      Our work machines are 64 bit Windows 10 computers with 8GB of Ram and i5 2.3 GHz processors. When we were using windows 7 we never had these issues, however; when we all switched over to windows 10 every macro we have that loops went to crap and slowed way down. I appreciate your effort and response, sadly I believe the only way my issue will be resolved is like you suggested. Get a faster processor or find a way to get a Windows 7 machine back (will never happen since were not supporting anymore for security reasons).

      Thanks again,


      • #4


        Should you need to dig further ....into speed matters ...

        Charles Williams is the world's top expert ...

        Have a look at his site :

        Hope this will help
        If you feel like saying "Thank You" for the help received ...You can click on the "Like" icon ...just underneath ... ... in the bottom right corner ...