Highlighting Rows and Cut to another worksheet

[DaveM]

Hi

Excel 2002

sheet1 Column A this is formatted as Text

0001
0001
0002
0002
0002
0002
0002
0003
0003


I would like to hightlight the Rows of the first series of numbers, in this
case Rows A1,A2
Cut and paste them in sheet2, leaving......

0002
0002
0002
0002
0002
0003
0003


and when I use the code again it would move the 0002s

Thanks in advance

Dave

 

[Mike H]

Hi,

Right click sheet1 tab, view code and paste this in. Note that this appends
to the data on sheet2

Sub copyit()
Dim myrange, MyRange1 As Range
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Set myrange = Range("A2:A" & lastrow)
firstvalue = Range("A1").Value
Set MyRange1 = Rows(1)
For Each c In myrange
If c.Value = firstvalue Then
Set MyRange1 = Union(MyRange1, c.EntireRow)
End If
Next
If Not MyRange1 Is Nothing Then
MyRange1.Copy
lastrow = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("Sheet2").Range("A" & lastrow + 1).PasteSpecial
'Sheets("Sheet2").Range("A1").PasteSpecial
MyRange1.Delete
End If
End Sub


Mike

 

[DaveM]

Thanks Mike

Works a treat

All the best

Dave

Hi,

Right click sheet1 tab, view code and paste this in. Note that this
appends
to the data on sheet2

Sub copyit()
Dim myrange, MyRange1 As Range
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Set myrange = Range("A2:A" & lastrow)
firstvalue = Range("A1").Value
Set MyRange1 = Rows(1)
For Each c In myrange
If c.Value = firstvalue Then
Set MyRange1 = Union(MyRange1, c.EntireRow)
End If
Next
If Not MyRange1 Is Nothing Then
MyRange1.Copy
lastrow = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row
Sheets("Sheet2").Range("A" & lastrow + 1).PasteSpecial
'Sheets("Sheet2").Range("A1").PasteSpecial
MyRange1.Delete
End If
End Sub


Mike

 

[Mike H]

Glad I could help

Thanks Mike

Works a treat

All the best

Dave