找到根据数组重新排序行所需的最小移动序列答案

【问题标题】：Find the smallest sequence of move needed to re-order rows according to an array找到根据数组重新排序行所需的最小移动序列
【发布时间】：2020-09-07 18:22:52
【问题描述】：

我正在编写一个 VBA 脚本，该脚本根据几个自定义条件对行进行排序。由于操作 Excel 行很慢（具有各种样式的大行），我正在通过内存中的一个对象进行排序：

生成一个表示工作表的锯齿状数组（仅包含排序过程中使用的相关信息）。
通过应用快速排序算法的组合对锯齿状数组进行排序。
使用排序后的交错数组作为参考重新生成工作表

第 1 步和第 2 步只需要 0,84s 即可继续进行（对于我最大的工作表）。但是最后一步，重新生成 Excel 工作表，需要很长时间：总共 129,11s！

这是我重新生成工作表的代码的简化示例：

Dim WS As Worksheet: Set WS = Worksheets("MySheet")
Dim EndRowIndex As Integer: EndRowIndex = WS.UsedRange.Rows.Count
Dim Destination As Integer: Destination = EndRowIndex + 1 
Dim rowIndex As Integer
Dim i As Integer

For i = 1 To EndRowIndex 
  rowIndex = new_order_array(i)
  WS.Rows(rowIndex).Copy
  WS.Rows(destination).Insert Shift:=xlDown 'Copying the rows in the correct order at the bottom
  destination = destination + 1  'incrementing the destination row (so it stays at the bottom)
Next
Application.CutCopyMode = False
WS.Rows("1:"& endRowIdex ).Delete 'Deleting the old unordered rows from the sheet

( new_order_array 是在第 2 步生成的，它的元素与工作表中的行数一样多。它表示需要移动哪一行，其中：new_order_array(1) = 3，表示第 3 行需要成为第 1 行。）

如您所见，这是一个简单但幼稚的重新排序。我在底部以正确的顺序复制每一行，然后在顶部删除每个无序的行。

为了完全优化流程，我需要使用最少的移动次数来重新排序工作表。目前，重新生成 N 行的工作表需要 N 次复制粘贴，而巧妙地移动行则需要 最多 N-1 次移动。如何找到根据数组重新排序行所需的最小移动序列？

我不知道是否要开始我的这项任务的研究......是否有关于这个主题的现有算法？这个问题是否命名（对关键字有用）？我是否错过了其他可能会提高性能的东西（我已经在此过程中禁用了视觉更新）？任何帮助将不胜感激。

【问题讨论】：

建议：1) 将工作表读入 VBA 数组（一步：arr=range）。 2) 在 VBA 数组中进行所有排序/过滤，以创建一个包含整个范围的输出数组。 3）将数组写回工作表（再次，一步：range=arr）。
这是一个有趣的提议，但看起来在将范围放入数组时会丢失一些属性。我必须保留行样式，并且我需要能够在排序过程中读取它们的 OutlineLevel 属性。
是的，该方法只保留单元格内容，而不是属性。由于您似乎需要多次写入工作表，建议您禁用 ScreenUpdating、Calculation、Cursor、DisplayAlerts、EnableEvents、Interactive 和 StatusBar，看看这是否足够加快速度.不过，我不知道您的“最小移动”问题。
另一个想法：在你有一个 VBA 数组或集合之后，让我们说，要按照你希望的顺序复制/粘贴的行号，执行复制/粘贴成组的连续行。这应该会减少操作的数量，具体取决于重新排序的结果。
WS.Rows(new_order_array(i)).Copy 为您节省 EndRowIndex 引用。

标签： excel vba performance optimization

【解决方案1】：

这是n 步骤中相当快速的排序算法。

打乱的数据：

'demo
Cells.Clear
Dim arr(1 To 100)
For i = 1 To 100
    arr(i) = i
Next i
'scramble
Randomize
Dim rarr(1 To 100)
x = 100
While x > 0
    r = Int(Rnd * x) + 1
    rarr(101 - x) = arr(r)
    arr(r) = arr(x)
    x = x - 1
Wend
For i = 1 To 100
    Cells(i, 1) = rarr(i)
Next i

排序：

'sort
sp = 1 'start position
While sp < 101
    If rarr(sp) = sp Then
    WS.Rows(sp).Copy
    WS.Rows(destination).Insert Shift:=xlDown
    destination = destination + 1
    sp = sp + 1
    Else
    d = rarr(rarr(sp))
    rarr(rarr(sp)) = rarr(sp)
    rarr(sp) = d
    End If
Wend
For i = 1 To 100
    Cells(i, 2) = rarr(i)
Next i
End Sub

rarr 数组已恢复。

它的工作原理是将第一个元素与第一个元素位置的元素交换，并重复此操作直到正确的元素就位，复制/粘贴它，然后移动到处理元素 2，并在整个过程中继续这样数组。

保证可以工作（在一组连续的整数 1..k 上），因为一旦元素处于正确位置，就不会再次引用它。

【讨论】：