Question

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

在：

后：

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

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

Answer 2

使用.statusbar和doevents（barrowc的赞美）方法的示例

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
Application.StatusBar = i & "/" & dU1.Count - 1
ReDim MyArray(1 To 1) As Variant

For j = 2 To 50
    a = 0
    Application.StatusBar = i & "/" & dU1.Count - 1 & " - " & j & "/50"
    For k = 2 To lrU
        Application.StatusBar = i & "/" & dU1.Count - 1 & " - " & j & "/50" & " - " & k & "/" & lrU
        DoEvents
        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
Application.StatusBar = ""
End Sub

Excel无响应VBA

2 个答案: