VBA copy rows with certain values

I would like to copy only certain rows to a new worksheet in the same workbook using VBA.

Copy Row 1 - header row

Copy each row whose "On Hand" number equals 1.

See attached sample worksheet.

ScreenshotBook1.xls
LVL 2
mcnuttlawAsked:
Who is Participating?

Improve company productivity with a Business Account.Sign Up

x
 
dlmilleConnect With a Mentor Commented:
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))
    
    On Error Resume Next
    Set wksNew = wkb.Worksheets("End Result")
    If Err.Number <> 0 Then
        Set wksNew = wkb.Worksheets.Add(after:=wkb.Worksheets(wkb.Worksheets.Count))
        wksNew.Name = "End Result"
    End If
    
    wksNew.Cells.Clear
    
    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
            
    wks.Activate
End Sub

Open in new window


Ok.  see attached.

Dave
Book1.xls
0
 
dlmilleCommented:
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

Open in new window


See attached.

Dave
Book1.xls
0
 
mcnuttlawAuthor Commented:
Oops.  I forgot to mention that the new worksheet is actually an existing one titled "End Result".

Pressing the button should replace the existing contents of "End Result".
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.