OK Tigger

I've modified the macro using the great Bob Phillip's method of deleting
rows. Hope that this is what you want.

Sub CopyData()
Dim myRange As Range, MatchRange As Range
Application.ScreenUpdating = False
'Sheets("Sheet2").Activate
'Cells.ClearContents
Sheets("sheet1").Select
Set myRange = Range("D2:D25")
For Each c In myRange
c.Select
If c.Value = 1 Then
Selection.EntireRow.Copy
Worksheets("Sheet2").Rows("1:1").Insert Shift:=xlDown
If MatchRange Is Nothing Then
Set MatchRange = Cells(c.Row, 4)
Else
Set MatchRange = Union(MatchRange, Cells(c.Row, 4))
End If
End If
Next c
Application.CutCopyMode = False
If Not MatchRange Is Nothing Then
MatchRange.EntireRow.Delete
End If
Range("a1").Select
Application.ScreenUpdating = True
End Sub


Regards
Peter

By the way, Bill Liddel was a great Liverpool Football (socer) player.

"TheTigger" wrote:

Peter -

Thank you so much but what would work best is if the data would remain
on sheet two but removed from sheet one once it has been run.

any suggestions?





On Jun 20, 10:21 am, Billy Liddel
wrote:
Hi I've modified it slightly. It now deletes the cells in sheet2 so that data
will not be duplicated if the macro has been run before. Once you have copied
it into a VBModule ALT + F!!, Insert Module (paste) you can run it from sheet
1.

If you intend to run it continually Place a Command button on your sheet1
(View, Forms) and select command button and draw it on sheet1. You will be
prompted to assign a macro so select CopyDAta

Sub CopyData()
Dim myRange As Range
Application.ScreenUpdating = False
Sheets("Sheet2").Activate
Cells.ClearContents
Sheets("sheet1").Select
Set myRange = Range("D2:D25")
For Each c In myRange
c.Select
If c.Value = 1 Then
Selection.EntireRow.Copy
Worksheets("Sheet2").Rows("1:1").Insert Shift:=xlDown
End If
Next
Application.CutCopyMode = False
Range("a1").Select
Application.ScreenUpdating = True
End Sub

Click the button and away you go.

Regards
Peter



" wrote:
Sub versive()
Dim myRange As Range
Set myRange = Range("D2:D25")
For Each "c" c.Select
If c.Value = 1 Then
Selection.EntireRow.Copy
Worksheets("Sheet2").Rows("1:1").Insert Shift:=xlDown
End If
Next
End Sub

The above formula was given to me by a "Mike" but I am uncertain how
to use it.

what I am trying to do is make excel pickout data that equals a
certain text value and move it automatically to another worksheet in a
workbook.

If anyone can help me out here I would appreicate it. I am NOT
allowed to use ACCESS I must use Excel.- Hide quoted text -

- Show quoted text -