vba - Excel没有响应VBA

Question

我正在运行一个脚本，它将具有相同名称的行合并在一起，将每个行的数据连接在一起，如下所示:

前:



后:



该脚本可以工作，但是在将它与更多列 (45) 和更多行 (1000+) 一起使用时，它会导致 Excel 停止响应，并且通常在它完成之前就崩溃了。我想知道，因为它使用较少的列(尽管仍然很慢并且显示为没有响应)，有没有办法让它以可管理的 block 来完成？或者使它不太可能停止响应/给出一些关于进展的提示(因为很难判断它是否仍在工作/还剩多长时间，或者它是否只是崩溃并且不再做任何事情 - 尝试将 64 位 Office 作为 32 -由于某种原因安装了位，可能会有所帮助)

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

我相信 Excel 被任务重载了。如果循环内没有单元格读取和“ReDim Preserve”，效率会更高。
试试这个来折叠你的数据:

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