無限ループ実行マクロ

Question

私は、ほとんど11k行のデータセットに対して最初のマクロを実行しようとしています。しかし、私はそれを実行すると、Excelをフリーズして強制終了しなければなりません。

私は、各行のセル11に "blue | red | gray | round"という要素が1〜5個入っています。その行のセル11を要素に更新して、その行全体を各要素の新しいシートにコピーします。

この例では、上記の4つの要素で、4つの行（各要素に1つ）が新しいシートに書き込まれます。

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

あなたがあればかなり高速に実行する必要があります

• 制限ではなく、行全体の実際に「埋め」細胞、

• コピー値にそれぞれの行からコピーする範囲範囲の間だけ

• WrdArrayをループせず、その値をワンショットで貼り付けます。

は以下の好き

セルK15は `のようなものが含まれている場合

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