運行無限循環的宏

我試圖運行我的第一個宏，對着幾乎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

來源

2017-02-18 Emile

如果單元格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

來源

2017-02-18 21:23:15 YowE3K

工作表在拼寫錯誤結束時拼寫錯誤。這在較小的數據集中工作（僅用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

來源

2017-02-18 22:12:35 user3598756

運行無限循環的宏

回答

相關問題