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

Answer 1

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

Answer 2

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