VBA For Each loop cuts short

Question

Trying to utilize some VBA loops, but ran into trouble. The code below runs through each Excel Table Listrow and if value is found in columns Value1 or Value2, new table row is created below the processed Listrow + value is fetched to the "Extracted" column.

It works, however according to the screenshots below the loop does technically cut short and wouldn't complete processing some rows.

Could it be that the loop fixes the amount of cycles in the beginning (7 rows), however also newly created rows are being looped through and the loop ends before the entire table is processed (there will be more rows in the table once the loop is finished).

Is there a neat way to fix this? Should the For Each loop be swapped to For next? Although hardcoding the number of loops is far from ideal (though a step forward). Or can the For each loop be made to somehow ignore newly created rows?

Table before code is run:

Table after completion:

Sub Extract_values()

Dim ws As Worksheet
Set ws = ActiveSheet
Dim tbl As ListObject
Set tbl = ws.ListObjects("myTable")

Dim lstobj As ListObject
Dim lstrw As ListRow
Dim i As Long

i = 1

Set lstobj = ActiveSheet.ListObjects("myTable")

For Each lstrw In lstobj.ListRows

    If Intersect(lstrw.Range, lstobj.ListColumns("Value1").Range).Value <> "" Then

    Set newrow = tbl.ListRows.Add(i + 1)

    With newrow
    .Range(1).Value = .Range(1).Offset(-1, 2).Value
    End With

    End If

    If Intersect(lstrw.Range, lstobj.ListColumns("Value2").Range).Value <> "" Then

    Set newrow = tbl.ListRows.Add(i + 2)

    With newrow
    .Range(1).Value = .Range(1).Offset(-2, 3).Value
    End With

    End If

i = i + 1

Next lstrw

End Sub

Answer 1

You can do something like this:

Sub Tester()

    Dim tbl As ListObject, r As Long, n As Long, v, e
    Dim rw As ListRow, rwNew As ListRow, exCol As Long

    Set tbl = ActiveSheet.ListObjects("Table1")
    exCol = tbl.ListColumns("Extracted").Index

    'loop backwards over rows
    For r = tbl.ListRows.Count To 1 Step -1
        Set rw = tbl.ListRows(r)
        n = 1
        'loop over source value columns
        For Each e In Array("Value1", "Value2")
            v = rw.Range.Cells(tbl.ListColumns(e).Index).Value
            'have a value to move?
            If Len(v) > 0 Then
                'add a row below and copy the value
                tbl.ListRows.Add(r + n).Range.Cells(exCol).Value = v
                n = n + 1 'increment next new row position
            End If
        Next e
    Next r

End Sub

Answer 2

Try

Sub Extract_values2()

    Dim Ws As Worksheet
    Dim Tbl As ListObject
    Dim rngDB As Range
    Dim lstobj As ListObject
    Dim lstrw As ListRow
    Dim i As Long, c As Integer
    Dim n As Long
    Dim vDB, vR()

    Set Ws = ActiveSheet
    Set lstobj = Ws.ListObjects("myTable")
    Set rngDB = lstobj.DataBodyRange

    vDB = rngDB
    c = UBound(vDB, 2)
    For i = 1 To UBound(vDB, 1)
            n = n + 1
            ReDim Preserve vR(1 To c, 1 To n)
            For j = 1 To c
                vR(j, n) = vDB(i, j)
            Next j
        If vDB(i, 3) <> "" Then
            n = n + 1
            ReDim Preserve vR(1 To c, 1 To n)
            vR(1, n) = vDB(i, 3)
        End If
        If vDB(i, 3) <> "" Then
            n = n + 1
            ReDim Preserve vR(1 To c, 1 To n)
            vR(1, n) = vDB(i, 4)
        End If
    Next i
    rngDB.Range("a1").Resize(n, c) = WorksheetFunction.Transpose(vR)

End Sub