Excel Not Responding VBA

Question

I am running a script which merges rows with the same name together, joining the data from each together, like so:

Before:

After:

The script works, but upon using it with more columns (45), and more rows (1000+) it causes Excel to stop responding, and usually crash before it can even complete. I was wondering, as it works with less columns (albeit still very slow and showing as not responding), is there a way to get it to do it in manageable chunks? Or make it less likely to stop responding/give some hint on progress (As it's hard to tell if it's still working/how long is left, or if it's simply crashed and no longer doing anything - attempting 64-bit of Office as 32-bit was installed for some reason, may help)

Sub OnOneLine()

Dim dU1 As Object, cU1 As Variant, iU1 As Long, lrU As Long
Dim MyArray() As Variant
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim h As Integer

Set dU1 = CreateObject("Scripting.Dictionary")
lrU = Worksheets("LOOKUP").Cells(Rows.Count, 1).End(xlUp).Row
cU1 = Worksheets("LOOKUP").Range("A2:A" & lrU)
For iU1 = 1 To UBound(cU1, 1)
dU1(cU1(iU1, 1)) = 1
Next iU1

For i = 0 To dU1.Count - 1
ReDim MyArray(1 To 1) As Variant

For j = 2 To 50
    a = 0
    For k = 2 To lrU
        If (Worksheets("LOOKUP").Cells(k, 1).Value = dU1.keys()(i) And Worksheets("LOOKUP").Cells(k, j).Value <> "") Then
                MyArray(UBound(MyArray)) = Worksheets("LOOKUP").Cells(k, j).Value
                ReDim Preserve MyArray(1 To UBound(MyArray) + 1) As Variant
                a = a + 1
        End If
    Next
    If a = 0 Then
                MyArray(UBound(MyArray)) = ""
                ReDim Preserve MyArray(1 To UBound(MyArray) + 1) As Variant
    End If
Next
Worksheets("Index").Cells(i + 2, 1) = dU1.keys()(i)

For h = 2 To UBound(MyArray)
        Worksheets("Index").Cells(i + 2, h) = MyArray(h - 1)
Next
Next

End Sub

Application.StatusBar = "X/X" - You could try using this? you can put any string into it but remember to return it to "" after use. I use this to stop the not responding message, just post this in a few of your loops. Obv replace "X/X" with something like i & "/" & dU1.Count - 1 — 99moorem, Mar 09 '16 at 16:29
Try adding `Application.ScreenUpdating = False` at the beginning and then setting it back to true just before the end of the Sub with `Application.ScreenUpdating = True` — Jordan, Mar 09 '16 at 16:30
To keep Excel responsive, add the line `DoEvents` just after the `For k = 2 To lrU` line. That lets Excel handle any pending events which may have built up — barrowc, Mar 09 '16 at 16:30
Just tried, `Application.ScreenUpdating = False` it doesn't seem to make a difference with Excel stop responding, thanks for the suggestion, will leave it in place as sure it makes it quicker (certainly didn't stop responding quite as quickly) — KML, Mar 09 '16 at 16:34
`ReDim Preserve` is an expensive operation, especially performing it so many times in a loop. If you could describe what you're *actually trying to do* (not the code, but what is the *intent* of the code?) there may be a better way to handle this... — David Zemens, Mar 09 '16 at 16:55
Cheers, with the `Application.StatusBar = "X/X"` and `DoEvents` it works perfectly stops Not responding, and gives me an idea of where it's at! :) — KML, Mar 09 '16 at 17:12
Sure thing David, There should be two pictures in my original post before and after, that is what I'm trying to achieve. I have 1426 records, out of those records I need to merge the contents of rows which have the same Name (A1) [They can be put next to each other if easier]. There'll only ever be two rows with the same name, and there wont be any issue with data existing in both rows in the same column, if data is in one of the rows, that same field will be blank in the other. Just need to get it all on one line :) — KML, Mar 09 '16 at 17:17

score 1 · Answer 1 · answered Mar 09 '16 at 18:04

I believe Excel is overloaded by the task. It would be more efficient if there were no cell reading and no "ReDim Preserve" inside the loop. Try this to collapse you data:

Const column_id = 1
Const column_first = 2
Const column_second = 4

Dim table As Range, data(), indexes As New Collection, index&, r&, c&

' get the range and the data
Set table = [LOOKUP!A1].CurrentRegion
data = table.Value2

' store the indexes for the rows were the first dataset is not empty
For r = 2 To UBound(data)
  If data(r, column_first) = Empty Then Exit For
  indexes.Add r, data(r, column_id)
Next

' collapse the data were the second dataset is not empty
For r = 2 To UBound(data)
  If Not VBA.IsEmpty(data(r, column_second)) Then
    index = indexes(data(r, column_id))
    For c = column_second To UBound(data, 2)
      data(index, c) = data(r, c)
      data(r, c) = Empty
    Next
    data(r, column_id) = Empty
  End If
Next

'copy the data back to the sheet
table = data

score 0 · Answer 2 · answered Mar 09 '16 at 16:47

Example using the .statusbar and doevents (compliments of barrowc) methods

Sub OnOneLine()

Dim dU1 As Object, cU1 As Variant, iU1 As Long, lrU As Long
Dim MyArray() As Variant
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim h As Integer

Set dU1 = CreateObject("Scripting.Dictionary")
lrU = Worksheets("LOOKUP").Cells(Rows.Count, 1).End(xlUp).Row
cU1 = Worksheets("LOOKUP").Range("A2:A" & lrU)
For iU1 = 1 To UBound(cU1, 1)
dU1(cU1(iU1, 1)) = 1
Next iU1

For i = 0 To dU1.Count - 1
Application.StatusBar = i & "/" & dU1.Count - 1
ReDim MyArray(1 To 1) As Variant

For j = 2 To 50
    a = 0
    Application.StatusBar = i & "/" & dU1.Count - 1 & " - " & j & "/50"
    For k = 2 To lrU
        Application.StatusBar = i & "/" & dU1.Count - 1 & " - " & j & "/50" & " - " & k & "/" & lrU
        DoEvents
        If (Worksheets("LOOKUP").Cells(k, 1).Value = dU1.keys()(i) And Worksheets("LOOKUP").Cells(k, j).Value <> "") Then
                MyArray(UBound(MyArray)) = Worksheets("LOOKUP").Cells(k, j).Value
                ReDim Preserve MyArray(1 To UBound(MyArray) + 1) As Variant
                a = a + 1
        End If
    Next
    If a = 0 Then
                MyArray(UBound(MyArray)) = ""
                ReDim Preserve MyArray(1 To UBound(MyArray) + 1) As Variant
    End If
Next
Worksheets("Index").Cells(i + 2, 1) = dU1.keys()(i)

For h = 2 To UBound(MyArray)
        Worksheets("Index").Cells(i + 2, h) = MyArray(h - 1)
Next
Next
Application.StatusBar = ""
End Sub

That's awesome, that and the `DoEvents` work perfectly! The status bar is perfect, just running it now, looks like my code is possibly doing too much or something :/ Waiting to see if it'll repeat 757 times or not lol Cheers for the help --- Currently at `0/757 - 23/50 - 400/1426` — KML, Mar 09 '16 at 17:07
Some other ways to speed up this code: 1) `Application.Calculation = xlCalculationManual` before the beginning of the loop, 2) make a variant array, declare it as `Worksheets("Lookup").Range("B2:AX" & lrU).Value`, and loop over that array with j and k instead. See [this question](http://stackoverflow.com/q/13016249/5103770) for lots of good ideas. — Stadem, Mar 09 '16 at 18:08
You could also setup timers if you was really concerned about speed, would help you work out where is taking the most time. And as always taking any sheet reading out will speed up VBA code - by that I mean read the data into an array once at the start and then read out once at the end. — 99moorem, Mar 10 '16 at 10:33

Excel Not Responding VBA

2 Answers2