VBA For Every l oop сокращает

Question

Попытка использовать некоторые циклы VBA, но столкнулась с проблемой. Приведенный ниже код проходит через все списки таблиц Excel, и, если значение найдено в столбцах Value1 или Value2, новая строка таблицы создается ниже обработанного значения Listrow + и извлекается в столбец «Извлечено».

Работает, однако согласно скриншотам ниже, l oop технически обрезает и не завершит обработку некоторых строк.

Может быть, l oop фиксирует количество циклов в начале (7 строк) , однако, также только что созданные строки проходят через петлю, и l oop заканчивается до обработки всей таблицы (после завершения l oop в таблице будет больше строк).

Есть ли аккуратный способ это исправить? Нужно ли поменять For For l oop на For next? Хотя жесткое кодирование количества циклов далеко от идеала (хотя и шаг вперед). Или можно заставить For каждого l oop каким-то образом игнорировать вновь созданные строки?

Таблица перед выполнением кода:

Таблица после заполнения:

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

Вы можете сделать что-то вроде этого:

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

Попробуйте

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