Copy Rows Based On Criteria

  • Thread starter Thread starter Sean
  • Start date Start date
S

Sean

I have a workbook where I have thousands of rows of data. I want to
automatically extract the entire row if column "D" has an "X" in it, to a new
workbook. Is this possible??? Any help would be great...
 
Try some code like the following:

Sub AAA()
Dim R As Range
Dim Dest As Range
Dim WB As Workbook
Dim WS As Worksheet
Dim LastRow As Long

Set WS = ActiveSheet
With WS
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

Set WB = Workbooks.Add
Set Dest = WB.Worksheets(1).Range("A1")

Set R = WS.Range("A1")
Do Until R.Row < LastRow
If R.EntireRow.Cells(1, "D").Value = "X" Then
R.EntireRow.Copy Destination:=Dest
Set Dest = Dest(2, 1)
End If
Set R = R(2, 1)
Loop
End Sub

Cordially,
Chip Pearson
Microsoft Most Valuable Professional,
Excel, 1998 - 2010
Pearson Software Consulting, LLC
www.cpearson.com
 
The code below will check column D of the ActiveSheet in the Workbook
containing the code. It will copy any row that has an X in column D and put
it into sheet1 of a new workbook which is created by the macro. You will
need to modify the path and file name on the SaveAs line to suit your
specific needs.

Sub cpyX()
Dim lr As Long, rng As Range, sh As Worksheet
Dim nWB As Workbook, sh2 As Worksheet, lr2 As Long
Set sh = ThisWorkbook.ActiveSheet
lr = sh.Cells(Rows.Count, 4).End(xlUp).Row
Set rng = Range("D2:D" & lr)
Set nWB = Workbooks.Add
ActiveWorkbook.SaveAs Filename:="C:\Documents and Settings\myWb.xls"
Set sh2 = nWB.Sheets(1)
For Each c In rng
If UCase(c) = "X" Then
lr2 = sh2.Cells(Rows.Count, 1).End(xlUp).Row
c.EntireRow.Copy sh2.Range("A" & lr2 + 1)
End If
Next
End Sub
 
Back
Top