VBA freeze / timeout when processing large data sets

Hello!

I am currently working on a VBA code is incorporated in an Excel extraction from our back office system.
The code basically takes the Excel data, sorts, merges cells, add subtitles and frames and most importantly incorporates image files from the server corresponding to the references in the file.
So far so good, the code generally works like a charm and the output is exactly what I need.
That said, from a certain number of data sets the file stops processing and Excel freezes. I have searched if this is due to a timeout or something else, but without any luck so far...
The datasets I am trying to extract are not huge either, the maximum I have tried is 1400 lines of data. It freezes from around 500 lines upwards.
Any input would be appreciated as it would be important for me to have this working with larger data sets.

Thanks in advance & please don't hesitate to let me know if you need any additional information.

Chees,

Reno



Here is the code I have so far:

Code:

---

Sub Colombus_Start()
'
' Colombus_Start Macro
'
Dim columnBrand  As String: columnBrand = "A"
Dim columnGroup As String: columnGroup = "B"
Dim columnReference1 As String: columnReference1 = "C"
Dim columnReference2 As String: columnReference2 = "D"
Dim columnProduct As String: columnProduct = "E"
Dim columnImage As String: columnImage = "F"
Dim columnRangeReference1 As String: columnRangeReference1 = "C:C"
Dim counterRow As Long
Dim counterReference As Long
Dim strReference As String
Dim strImage As String
Dim intLastRow As Integer


Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False


intLastRow = Range("C" & Rows.Count).End(xlUp).Row


'Sort by Reference & Custom Sort by Size
With ActiveWorkbook.ActiveSheet.Sort
    With .SortFields
        .Clear
        'Sort by Reference
        .Add Key:=Range("C3:C" & intLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        'Sort by Colour
        .Add Key:=Range("G3:G" & intLastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        'Sort by Custom Range > Sizes
        .Add Key:=Range("J3:J" & intLastRow), CustomOrder:="TU, SS, XS, S, M, L, EL, XL"
    End With
    .SetRange Range("A3:V" & intLastRow)
    .Apply
End With


'Inserts SubTotals
Range("A3:V" & intLastRow).Select
Selection.Subtotal GroupBy:=3, Function:=xlSum, _
TotalList:=Array(14, 15, 16, 17, 18, 19, 20, 21, 22)


'Loop to change row height according to the number of rows per reference. This assures that the image will fit.
For counterRow = Cells(Rows.Count, columnReference1).End(xlUp).Row To 1 Step -1
strReference = Cells(counterRow, columnReference1)
counterReference = Application.WorksheetFunction.CountIf(Range(columnRangeReference1), strReference)


If Left(Cells(counterRow, columnReference1), 5) = "Total" Then
  Rows(counterRow).RowHeight = 23
  With Range(Cells(counterRow, "A"), Cells(counterRow, "V")).Borders(xlEdgeTop)
      .LineStyle = xlContinuous
      .ColorIndex = xlAutomatic
      .TintAndShade = 0
      .Weight = xlThin
  End With
  With Range(Cells(counterRow, "A"), Cells(counterRow, "V")).Borders(xlEdgeBottom)
      .LineStyle = xlContinuous
      .ColorIndex = xlAutomatic
      .TintAndShade = 0
      .Weight = xlMedium
  End With
  With Range(Cells(counterRow, "A"), Cells(counterRow, "V")).Borders(xlEdgeRight)
      .LineStyle = xlContinuous
      .ColorIndex = xlAutomatic
      .TintAndShade = 0
      .Weight = xlMedium
  End With
  With Range(Cells(counterRow, "A"), Cells(counterRow, "V")).Borders(xlInsideVertical)
      .LineStyle = xlContinuous
      .ColorIndex = xlAutomatic
      .TintAndShade = 0
      .Weight = xlMedium
  End With
  Range(Cells(counterRow, "A"), Cells(counterRow, "K")).Merge
  Range(Cells(counterRow, "A"), Cells(counterRow, "K")).VerticalAlignment = xlCenter
ElseIf Left(Cells(counterRow, columnReference1), 5) = "REF 1" Then
    Rows(counterRow).RowHeight = 48
ElseIf counterReference = 1 Then
    Rows(counterRow).RowHeight = 90
ElseIf counterReference = 2 Then
    Rows(counterRow).RowHeight = 45
ElseIf counterReference = 3 Then
    Rows(counterRow).RowHeight = 30
ElseIf counterReference = 4 Then
    Rows(counterRow).RowHeight = 23
ElseIf counterReference = 5 Then
    Rows(counterRow).RowHeight = 18
ElseIf counterReference = 6 Then
    Rows(counterRow).RowHeight = 15
End If
Next counterRow


'Deletes redundant images & merges cells with identical values
For counterRow = Cells(Rows.Count, columnReference1).End(xlUp).Row To 1 Step -1
If Cells(counterRow, columnReference1) = Cells(counterRow + 1, columnReference1) Then
On Error Resume Next
Range(Cells(counterRow, columnBrand), Cells(counterRow + 1, columnBrand)).Merge
Range(Cells(counterRow, columnGroup), Cells(counterRow + 1, columnGroup)).Merge
Range(Cells(counterRow, columnReference1), Cells(counterRow + 1, columnReference1)).Merge
Range(Cells(counterRow, columnReference2), Cells(counterRow + 1, columnReference2)).Merge
Range(Cells(counterRow, columnProduct), Cells(counterRow + 1, columnProduct)).Merge
Range(Cells(counterRow, columnImage), Cells(counterRow + 1, columnImage)).Merge
End If
Next counterRow


'Gets image URL, finds image on server and inserts in in the active cell
For counterRow = Cells(Rows.Count, columnImage).End(xlUp).Row To 1 Step -1
On Error Resume Next
strImage = Cells(counterRow, columnImage).Value
Cells(counterRow, columnImage).Activate
Selection = ActiveSheet.Shapes.AddPicture(strImage, False, True, ActiveCell.Left + 4, ActiveCell.Top + 4, 86, 70)
Next counterRow


Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True


ActiveWorkbook.Save
   
End Sub

---

Something that's easy to try is to add a "DoEvents" statement to the end of any loop that's doing a large number of iterations.

Example:

Code:

---

    'Gets image URL, finds image on server and inserts in in the active cell
    For counterRow = Cells(Rows.Count, columnImage).End(xlUp).Row To 1 Step -1
        On Error Resume Next
        strImage = Cells(counterRow, columnImage).Value
        Cells(counterRow, columnImage).Activate
        Selection = ActiveSheet.Shapes.AddPicture(strImage, False, True, ActiveCell.Left + 4, ActiveCell.Top + 4, 86, 70)
        DoEvents
    Next counterRow

---

Similar to rlv's

Something like this since you really don't have to DoEvents every time

Code:

---


For counterRow = Cells(Rows.Count, columnReference1).End(xlUp).Row To 1 Step -1

If counterRow Mod 100 = 0 then
    DoEvents
    Application.StatusBar = "Changing Row Height " & Format (counterRow, "#,##0")
End IF

---

and at the end of the macro

Code:

---

    Application.StatusBar = False

---

Dear Paul, dear RLV,

Thank you both for your replies, much appreciated.
So far no luck but the DoEvents might indeed be what's needed, I am currently running some tests in the different loops. Thanks for the advice on this and I will let you know if it works out.
Also, is there a way of finding out which loop causes the longest delay so that I can narrowing down the problem?

Thanks for your help & have a great weekend,

Reno

Quote:

---

Originally Posted by 125ml

Also, is there a way of finding out which loop causes the longest delay so that I can narrowing down the problem?

---

Fastest / Easiest way I know is to put a breakpoint (F9) on each for the 'For ...' lines and maybe some others and hit Run

It'll stop when it hit's the break-pointed line and you might get a feel for where to look next


Attachment 18985

You can also use a Debug.Print statement

Code:

---

Debug.Print "Loop 1 Complete!"

---

After each loop to see how far you get before it hangs.

Also, if this is a workbook you've been extensively working on and doing a lot of VBA editing over a long period of time, keep in mind that VBA is somewhat notorious for not properly cleaning up after itself. This can lead to very strange behavior at run time. I HIGHLY recommend installing Rob Bovey's free code cleaner and cleaning your project to clear out any 'garbage'.

http://www.appspro.com/Utilities/CodeCleaner.htm

Dera Paul, dear rlv,

Thank you both for your further comments, very much appreciated.
Both the Debug.Print as well as the DoEvents are new for me but very interesting and helpful, thanks for that. I have managed to get the file treated 100%, so that's great!
Code is still running slowly though so I am doing some further research to improve the macro. I noticed for example that the loop that resizes the line height runs superfast at the beginning but then slows down (a lot!) the further it gets through the file (around 3000 lines in total, at the beginning of the code it takes less that a second for the resizing per line, at towards the end it's around 10 seconds...). So I am trying to improve loop after loop to improve handling time. Will let you know when I have the final solution/code but so far your tips have been very helpful, thank you!

My best,

Reno