Как переместить UsedRange в массив для обработки задач, а затем скопировать обратно на лист?

Относительно этого вопроса «объединить или объединить ячейки с одинаковыми значениями по вертикали и горизонтали» Связь,
предоставленный ответ (отредактированный) работает, но с большим диапазоном (например, 30 тысяч строк) макрос занимает очень много времени (ошибка не возникает, но Excel не отвечает).
поэтому вместо того, чтобы помещать в массив только первый столбец,
Является ли это возможным, чтобы переместить все usedRange в массив и обработать все задачи в памяти, а затем скопировать обратно на лист?
Меня вообще не волнует потерянный формат (шрифты, высота строк и т. д.).
Заранее благодарен за помощь.

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