Excel数据分组分别放入新Sheet

Excel表格中的数据如下：

现在要求编写vba程序，使得数据按照Id分组，然后不同组的数据存入不同的Sheet。
解决思路：首先按照Id进行排序。然后遍历每行id单元格，与上一行的id值进行比较。不同则创建新Sheet，相同则复制该行数据到已创建的新Sheet。

Sub Copy2()
    Dim i As Long
    Dim j As Long

    
    Range("a:b").Sort key1:=[a1], order1:=xlAscending, Header:=xlYes
    '新表中已插入的数据的数量
    j = 1
    For i = 2 To Sheets("Sheet1").UsedRange.Rows.Count
        If Sheets("Sheet1").Cells(i, 1).Value = Sheets("Sheet1").Cells(i - 1, 1) Then
            Debug.Print "相等"
            '复制行到已创建的表
            Sheets("Sheet1").Rows(i).copy ActiveSheet.Rows(j)
            j = j + 1
        Else
            Debug.Print "不等"
            '创建新表
            Sheets.Add After:=ActiveSheet
            '重置已插入的数据数量
            j = 1
            Sheets("Sheet1").Rows(i).copy ActiveSheet.Rows(j)
            j = j + 1
        End If
    Next i
End Sub