How to move UsedRange into Array for processing tasks and then copy back to the sheet?

Question

Regarding this question “combine or merge cells with the same values vertically and horizontally” Link,
the provided answer (edited one) it works ,but with big range (e.g. 30 thousands rows) the macro takes a very long time to finish (no error raised but excel is not responding).
so, instead of putting only the first column on array,
Is it possible to move all the usedRange into array and processing all the tasks on memory and then copy back to the sheet?
I do not care about any lost format at all (fonts, rows height,..).
In advance, grateful for your helps.

Sub DeleteSimilarRows_AppendLastColuns()
    Dim LastRow As Long, ws As Worksheet, arrWork, rngDel As Range, i As Long, j As Long, k As Long
    Dim strVal As String, m As Long, boolNoFilter As Boolean
 
    Set ws = ActiveSheet: LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
 
    arrWork = ws.Range("A1:A" & LastRow).Value2 'Place the range in an array to make iteration faster
 
    Application.DisplayAlerts = False: Application.ScreenUpdating = False
    For i = 2 To UBound(arrWork) - 1                'Iterate between the array elements:
        If arrWork(i, 1) = arrWork(i + 1, 1) Then
            'Determine how many consecutive similar rows exist:__________________
            For k = 1 To LastRow
                If i + k + 1 >= UBound(arrWork) Then Exit For
                If arrWork(i, 1) <> arrWork(i + k + 1, 1) Then Exit For
            Next k '___________________________________________
 
            For j = 14 To 14                  'Build the concatenated string of cells in range "N":
                strVal = ws.Cells(i, j).Value
                For m = 1 To k
                    strVal = strVal & vbLf & ws.Cells(i + m, j).Value
                Next m
                ws.Cells(i, j).Value = strVal: strVal = ""
           Next j
 
           For m = 1 To k                    'Place the cells for rows to be deleted in a Union range, to delete at the end, at once
                If rngDel Is Nothing Then
                     Set rngDel = ws.Range("A" & i + m)
                Else
                    Set rngDel = Union(rngDel, ws.Range("A" & i + m))
                End If
         Next m
         i = i + k: If i >= UBound(arrWork) - 1 Then Exit For 'Increment the i variable and exiting if the resulted value exits the array size
       End If
    Next i
 
    If Not rngDel Is Nothing Then rngDel.EntireRow.Delete    'Delete the not necessary rows
    Application.DisplayAlerts = True: Application.ScreenUpdating = True
 
End Sub

Franz Reischl · Accepted Answer · 2022-05-06T09:40:43.513

1

It is not only possible, but preferable. The speed increase is insane. This is how I do it:

Data from the spread sheet gets saved into a variable from type Variant -- the result is a 2-dimensional array (even if there is only one row/column in the range).

' Read data into Array
Dim data as Variant ' Important: has to be type Variant. 
Set data = ActiveSheet.UsedRange.Value2 ' .Value or .Value2, as needed

When saving data back into the sheet, this code automatically selects a range of the appropriate size.

' Write array into cells
Dim target as Range
Set target = ActiveSheet.Cells(1,1) ' Start at A1 / R1C1; Change as appropriate
target.Resize(UBound(data, 1), UBound(data, 2)).Value = data

edited May 06 '22 at 09:40

answered May 06 '22 at 09:11

Franz Reischl

190
8

Your answer has a minor error. `(even if there is only one row/column/cell in the range)`. If the range is just ONE cell, assignment to a variant results in a scalar value and not a 2D array. – Excel Hero May 06 '22 at 09:34
You are correct - my mistake. I did correct it. – Franz Reischl May 06 '22 at 09:40

How to move UsedRange into Array for processing tasks and then copy back to the sheet?

1 Answers1