如何将UsedRange移动到Array中进行处理任务，然后复制回sheet？

Question

关于“合并或合并垂直和水平具有相同值的单元格”这个问题,
提供的答案（已编辑）有效，但范围很大（例如 3 万行），宏需要很长时间才能完成（没有出现错误，但 excel 没有响应）。
所以，不是只将第一列放在数组中，
是否可以将所有usedRange移动到数组中并处理内存中的所有任务，然后复制回sheet？
我根本不关心任何丢失的格式（字体、行高……）。
预先感谢您的帮助。

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

Answer 1

不仅可行，而且更可取。速度提升是疯狂的。我是这样做的：

来自传播 sheet 的数据被保存到 Variant 类型的变量中——结果是一个二维数组（即使范围内只有一个 row/column）。

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

将数据保存回 sheet 时，此代码会自动选择适当大小的范围。

' 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

如何将UsedRange移动到Array中进行处理任务，然后复制回sheet？

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

excel

vba