VBA copy rows with certain values

Option Explicit

Sub copyOnHand()
Dim wkb As Workbook
Dim wks As Worksheet
Dim wksNew As Worksheet
Dim rngOut As Range
Dim rng As Range
Dim r As Range
Dim i As Long

    Set wkb = ThisWorkbook
    Set wks = wkb.ActiveSheet
    
    Set rng = wks.Range("A2", wks.Range("A" & wks.Rows.Count).End(xlUp))
    
    Set wksNew = wkb.Worksheets.Add(after:=wkb.Worksheets(wkb.Worksheets.Count))
    
    wksNew.Range("A1").Resize(, 3).Value = wks.Range("A1:C1").Value
    
    Set rngOut = wksNew.Range("A2:C2")
    
    For Each r In rng
        If r.Offset(0, 2).Value > 0 Then
            rngOut.Offset(i).Value = r.Resize(, 3).Value
            i = i + 1
        End If
    Next r
            
End Sub

Select allOpen in new window