CODEWITHSUNDEEP
vbaexcel
Emile
Emile

Reputation: 3474

Macro running infinite loop

I'm trying to run my first macro against a dataset with almost 11k rows. However when I run it, it freezes Excel making me have to force quit it.

What I expect to happen is in cell 11 for each row, that contains 1-5 elements "blue|red|gray|round". I want to copy that entire row to a new sheet for each element, updating cell 11 in that row to the element.

So in this example, with the 4 elements above, 4 rows (one for each element) would be written to the new sheet.

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

Upvotes: 0

Views: 3037

Answers (2)

user3598756
user3598756

Reputation: 29421

you should run considerably faster if you:

  • limit ranges to be copied from each row to the actually "filled" cells, instead of the whole row

  • copy values only between ranges

  • don't loop through WrdArray and simply paste its values in one shot

like follows

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

Upvotes: 0

YowE3K
YowE3K

Reputation: 23974

You need to keep track of where you are writing on Sheet6, so that you aren't constantly writing over the top of a single row. (The code following uses a variable i6 to do that.)

You should also only run your loop down until you reach the last non-empty cell. (I have assumed in the following code that column K always contains a value in every row that is to be copied.) Otherwise you will be processing 1,048,576 rows, but you only have meaningful information in about 1% of those rows.

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

Upvotes: 1

Related Questions