Question

我试图针对行数近11k的数据集运行我的第一个宏。但是，当我运行它时，它会冻结Excel，因此我必须强行退出它。

我期望发生的是每行的单元格11，其中包含1-5个元素＆＃34; blue | red | gray | round＆＃34;。我想将整行复制到每个元素的新工作表，将该行中的单元格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上写作的位置，这样你就不会经常在一行的顶部写作。（以下代码使用变量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

Answer 2

如果您：

，你应该跑得快得多

限制范围从每一行复制到实际＆＃34;已填充＆＃34;单元格，而不是整行
仅在范围之间复制值
不要遍历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

宏运行无限循环

2 个答案: