请问如何将满足条件的行复制到同一表中

来源：百度知道 编辑：UC知道 时间：2024/05/13 18:26:42
A B C D
144240 BCD222HE3B 2 甲等品
144240 BCD218ZA3BR 1 甲等品
144249 BCD176CK 30 甲等品
144251 BCD176CK 30 甲等品
144251 BC86A 3 三等品
144251 BCD218ZM3B 1 甲等品
144251 BCD175C 5 甲等品
144251 BCD188ZM3 30 甲等品
144251 BCD186KH 8 甲等品
144251 BCD450ZE9 1 甲等品
144231 BCD450ZE9 1 甲等品
144231 BCD450ZE9 1 甲等品
144230 BC50 40 甲等品
144230 BCD188BCH 20 甲等品
144230 BCD206CK 30 甲等品
144230 BCD118ZM2 1 甲等品
144230 BCD175SC 1 甲等品
144230 BCD118ZM2 1 甲等品
144230 BCD175C 1 甲等品
144230 BCD175SC 1 甲等品
144230 FCD185AZ2 1 甲等品
比如A列中包含144240的就复制整行到sheet2中，包含144249的就复制整行到sheet3中，以此类推，谢谢，希望能发挥一下兄弟们的专长帮我解决这个问题。谢谢。 。
A列相同的数据都在一起的，就是想能分别自动的复制到新表中。谢谢

Sub xx()
x = 2
y = 1
For i = 1 To 100'设有100条记录
If i > 1 Then
If Cells(i, 1) <> Cells(i - 1, 1) Then
x = x + 1
y = 1
End If
End If
Rows(i).Select
Selection.Copy
Sheets(x).Select
Cells(y, 1).Select
ActiveSheet.Paste
Sheets(1).Select
y = y + 1
Next
End Sub

程序很笨，你414，也希望高手指点，编写更简洁的宏供俺学习。

无论你的数据有多少，用下面的宏，就能自动按你的要求处理完。

Sub Macro1()

' 这两句是以防万一数据没有排好，所以先排一次
Columns("A:D").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortNormal

Range("A1").Select
arow = ActiveCell.Row
表名 = ActiveSheet.Name

Do Until Cells(arow, 1).Value = 空值
新表名 = Cells(arow, 1).V