VBA - Пропуск строк при попытке перебрать все строки

Question

Я пытаюсь написать код, который будет перебирать каждую строку в каждой вкладке в электронной таблице, и если значения в столбцах W и X больше 0, запишите эту строку в следующую доступную строку на вкладке под названием «Бюджет»в той же таблице.Когда я запускаю это, он пропускает все остальные строки.Любой совет будет принят во внимание.Я думаю, что это как-то связано с выбранным диапазоном и относительно строки, но я не могу понять, как правильно установить контекст.

Sub Button1_Click()

Dim source As Worksheet
Dim target As Worksheet
Dim targetLastRow As Long
Dim LastRow As Long

Set target = ThisWorkbook.Sheets("Budget")
targetLastRow = target.Range("A" & target.Rows.Count).End(xlUp).Row

    For Each ws In Worksheets
        Set source = ws     
        'do not read rows from budget because that is our target
        If source.Name <> "Budget" Then 
            'get the last row in the current sheet
            LastRow = source.Cells(source.Rows.Count, "X").End(xlUp).Row

            Set rowRange = source.Range("A1:A" & LastRow)

            'Loop through each row
            For Each r In rowRange            
                'if column W and X have valuces then write the row to the target sheet
                If source.Cells(r.Row, 24) > 0 And source.Cells(r.Row, 23) > 0 Then      
                    target.Cells(targetLastRow, 1) = source.Cells(r.Row, 23)
                    'activeRow.EntireRow.Copy target.Cells(1, targetLastRow)
                    targetLastRow = targetLastRow + 1

                End If
            Next r

            MsgBox ("Processing complete for Sheet: " & source.Name)
        End If
    Next ws
End Sub

Answer 1

Попробуйте:

Option Explicit

Sub Button1_Click()

Dim Trg As Worksheet: Set Trg = ThisWorkbook.Sheets("Budget")
Dim a As Integer: a = Trg.Cells(Trg.Rows.Count, 1).End(xlUp).Row + 1
Dim T1(), ws As Worksheet, i As Integer

For Each ws In Worksheets
    If ws.Name <> "Budget" Then
        T1 = ws.Range("A1", ws.Cells.SpecialCells(xlCellTypeLastCell))
        For i = 1 To UBound(T1)
            If T1(i, 23) > 0 And T1(i, 24) > 0 Then
                ws.Cells(i, 1).EntireRow.Copy Trg.Cells(a, 1)
                a = a + 1
            End If
        Next i
        MsgBox ("Processing complete for Sheet: " & ws.Name)
    End If
Next ws
End Sub