Copy Rows Based On Criteria

[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...

 

[Chip Pearson]

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

 

[JLGWhiz]

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" & 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

 

[Gord Dibben]

Possible, yes.

Do you want a new workbook for every row with an "X"?

See Ron de Bruin's site for code and methods.

http://www.rondebruin.nl/copy5.htm


Gord Dibben MS Excel MVP