运行无限循环的宏

问题描述：

我试图运行我的第一个宏，对着几乎11k行的数据集。但是，当我运行它，它冻结Excel，使我不得不强制退出它。运行无限循环的宏

我希望发生的是每行的单元格11中包含1-5个元素“blue | grey | round”。我想将整行复制到每个元素的新工作表，将该行中的单元格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

如果单元格K15包含有类似“ ”123 | 4567 | ABC | DEF“'要复制的活动行（无论行，可能是）到Sheet6 4倍，然后将Sheet6上的K15更改为“123”，然后更改为“4567”，然后更改为“abc”，然后更改为“def”。为什么不复制活动行一次并将K15设置为'“def”'（而不是先将其设置为所有其他值）？你是否打算/需要将活动行复制到Sheet6中的每一行？（这可能是100万+单行的副本，只有K列不同，而且只有前面的11000行。） – YowE3K

伟大的一点 - 我会改变它 – Emile

其实，你不会得到100万份+你只是对表单执行“粘贴”，而不是对表单中的“i”进行排序。如果这种方法甚至有效，我认为它会不断粘贴到Sheet6的“活动”行，或者可能粘贴到Sheet6的第一行。 – YowE3K

答

您需要跟踪您在Sheet6上书写的位置，以便您不会一直在写单行的顶部。（下面的代码使用变量i6来做到这一点。）

你也应该只运行你的循环，直到你到达最后一个非空单元。（我已经在下面的代码中假设列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

工作表在拼写错误结束时拼写错误。这在较小的数据集中工作（仅用5行进行测试）。 – Emile

然而，你是对的 - 一些行没有值。我敢打赌，这是问题。 – Emile

@Emile - 感谢您发现错字 - 现在修复。 – YowE3K

答

你应该相当快运行，如果你：不是整排

限制的范围是从各行复制到实际上是“装”的细胞，
复制值只在范围之间
不会循环通过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

运行无限循环的宏

相关推荐