Excel不响应VBA

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

之前：

后：

这个脚本可以工作，但是在使用更多的列（45）和更多的行（1000+）时，会导致Excel停止响应，并且在甚至完成之前通常会崩溃。 我想知道，因为它与较less的列工作（尽pipe仍然非常缓慢，显示为没有响应），有没有办法让它做到可pipe理的块？ 或者让它不太可能停止响应/提供一些进度提示（因为很难判断它是否还在工作/剩下多长时间，或者它只是崩溃，不再做任何事情 – 试图将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 

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