请尝试下一个代码：

Sub returnGropFirsRow()
 Dim sh1 As Worksheet,sh2 As Worksheet,lastR1 As Long,arr,arrFin,i As Long,k As Long
 
 Set sh1 = Worksheets("Sheet1")
 Set sh2 = Worksheets("Sheet2")
 astR1 = sh1.Range("A" & sh1.rows.count).End(xlUp).row 'last row in sh1
 arr = sh1.Range("A1:F" & lastR1).value                         'put the range in an array to make the code faster
 
 ReDim arrFin(1 To 3,1 To UBound(arr) + 1): k = 1               'redim the final array to have place for all possible cases
 
 arrFin(1,k) = "ID": arrFin(2,k) = "Name": arrFin(3,k) = "Group" 'put the header in the final array
 For i = 2 To UBound(arr)                                           'iterate between the arr elements
    If arr(i,6) <> arr(i - 1,6) Then                              'if arr element not equal with the one above it:
        k = k + 1                                                   'increment k (future row) variable
        arrFin(1,k) = arr(i,1): arrFin(2,2): arrFin(3,6) 'load the necessary elements in the final array
    End If
 Next i
 
 ReDim Preserve arrFin(1 To 3,1 To k)      'redim final array in order to keep only the filled values
  'drop the array content at once and format the range:
 Dim arrBord,El
 arrBord = Application.Evaluate("Row(7:12)")
 With sh2.Range("A1").Resize(UBound(arrFin,2),UBound(arrFin))
    .value = Application.Transpose(arrFin)
    .EntireColumn.AutoFit
    For Each El In arrBord
        With .Borders(El)
          .LineStyle = xlContinuous: .Weight = xlThin: .ColorIndex = 0
        End With
    Next El
    .BorderAround,xlMedium
    With .Range(.cells(1,1),.cells(1,3))
        .Font.Bold = True
        .BorderAround,xlMedium
        .Interior.ColorIndex = 20
        .HorizontalAlignment = xlCenter
    End With
 End With
End Sub

因为您正在处理表格，所以这是我的方法。 代码有一些注释，但如果需要，请逐步调试以更好地理解。

Sub copyFirstRowOfEachGroup()
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim ol As ListObject: Set ol = ws.ListObjects(1)
    Dim olColOrder As ListColumn,olColRank As ListColumn
    Dim olColRng As Range
    
    On Error GoTo errhandler
    
    ' Add temporary columns: Order & Rank
    Set olColOrder = ol.ListColumns.Add: olColOrder.Name = "Order"
    Set olColRank = ol.ListColumns.Add: olColRank.Name = "Rank"
    
    ' create an order depending on the ROW
    Set olColRng = olColOrder.DataBodyRange
    olColRng.FormulaR1C1 = "=[@Group]+ROW(R[1]C[1])/100000"
    
    ' set the rank in each goup
    Set olColRng = olColRank.DataBodyRange
    olColRng.FormulaR1C1 = "=COUNTIFS([Group],[@Group],[Order],""<""&[@Order])+1"
    
    ' set advanced filter criteria
    ws.Range("M1").Value = "Rank"
    ws.Range("M2").Value = 1
    Dim crtRng As Range: Set crtRng = ws.Range("M1:M2")
    
    ' set destination range
    ws.Range("G1").Value = "ID"
    ws.Range("H1").Value = "Name"
    ws.Range("I1").Value = "Group"
    Dim dstRng As Range: Set dstRng = ws.Range("G1:I1")
    
    ' advanced filter
    ol.Range.AdvancedFilter _
        Action:=xlFilterCopy,_
        CriteriaRange:=crtRng,_
        CopyToRange:=dstRng,_
        Unique:=False

    ' delete temporay columns and advanced filter criteria
    crtRng.ClearContents
    olColOrder.Delete
    olColRank.Delete
    
errRoutine:
    ' clean
    Set crtRng = Nothing
    
    Exit Sub

errhandler:
    Debug.Print Err.Number,Err.Description
    Resume errRoutine
End Sub

这是我的文件：https://www.dropbox.com/s/r42riiylcss5j7w/CopyWithCriteria.xlsm?dl=0