macros运行无限循环

我试图运行我的第一个macros对数据集近11k行。 但是，当我运行它，它冻结Excel使我不得不强制退出它。

我想要发生的是在每一行的单元格11中，包含1-5个元素“蓝色”。 我想将整行复制到每个元素的新工作表，将该行中的单元格11更新为元素。

所以在这个例子中，对于上面的4个元素，4行（每个元素一个）将被写入新的表单。

Option Explicit Sub ReorgData2() Dim i As Long Dim WrdArray() As String Dim element As Variant Application.ScreenUpdating = False With Sheets("Sheet5") For i = 1 To Rows.Count WrdArray() = Split(.Cells(i, 11), "|") For Each element In WrdArray() ActiveCell.EntireRow.Copy Sheets("Sheet6").Paste Sheets("Sheet6").Cells(i, 11) = element Next element Next i End With Application.ScreenUpdating = True End Sub 

Answer 1

你需要跟踪你在Sheet6上写的地方，这样你就不会一直写在单行的顶端。 （下面的代码使用variablesi6来做到这一点。）

你也应该只运行你的循环，直到你到达最后一个非空单元。 （我已经在下面的代码中假设列K总是包含每行要复制的值）否则，您将处理1,048,576行，但只有大约1％的行中有有意义的信息。

 Option Explicit Sub ReorgData2() Dim i5 As Long Dim i6 As Long Dim WrdArray() As String Dim element As Variant Application.ScreenUpdating = False With Worksheets("Sheet5") For i5 = 1 To .Cells(.Rows.Count, "K").End(xlUp).Row WrdArray() = Split(.Cells(i5, 11), "|") For Each element In WrdArray() i6 = i6 + 1 ' increment a counter each time we write a new row .Rows(i5).Copy Worksheets("Sheet6").Rows(i6) Worksheets("Sheet6").Cells(i6, 11).Value = element Next element Next i5 End With Application.ScreenUpdating = True End Sub 

Answer 2

你应该跑得快得多，如果你：

• 限制范围从每行复制到实际“填充”单元格，而不是整行

• 仅在范围之间复制值

• 不要通过WrdArray循环，只需简单地粘贴它的值

如下所示

 Sub ReorgData2() Dim WrdArray As Variant Dim cell As Range Dim lastRow As Long Set sht6 = Worksheets("Sheet6") Application.ScreenUpdating = False With Worksheets("Sheet5") For Each cell In .Range("K1", .Cells(.Rows.count, "K").End(xlUp)).SpecialCells(xlCellTypeConstants, xlTextValues) '<--| loop through column K cells with text values only WrdArray = Split(cell, "|") With .Range(.Cells(cell.row, 1), .Cells(cell.row, .Columns.count).End(xlToLeft)) '<--| reference current row range from column 1 to last not empty one lastRow = sht6.Cells(Rows.count, 1).End(xlUp).Offset(1).row '<--| find sheet 6 column A first empty row index after last not empty cell sht6.Cells(lastRow, 1).Resize(UBound(WrdArray) + 1, .Columns.count).Value = .Value '<--| copy referenced range to as many sheet6 rows as 'WrdArray' elements sht6.Cells(lastRow, 11).Resize(UBound(WrdArray) + 1).Value = Application.Transpose(WrdArray) '<--| update sheet 6 column K only with 'WrdArray' elements End With Next End With Application.ScreenUpdating = True End Sub