Transfer data based on values in range to related sheets

Hi,

Using array (as alternative to my Avenger team who use AutoFilter) :

Sub Test()
  Dim arrData, arrSheet, i As Long, j As Long

  ReDim arrSheet(1 To Worksheets.Count, 1 To 2)
  With Sheets("Data")
    For i = 1 To Worksheets.Count
        arrSheet(i, 1) = Worksheets(i).Name                             'Set sheet's name
        Set arrSheet(i, 2) = Intersect(.Rows("1:5"), .Columns("A:G"))   'Set header
    Next i
    arrData = .Range("A1:G" & .Cells(.Rows.Count, "A").End(xlUp).Row)
    For i = 6 To UBound(arrData, 1)
        For j = 1 To UBound(arrSheet, 1)
            If arrSheet(j, 1) = arrData(i, 7) Then
               Set arrSheet(j, 2) = Union(arrSheet(j, 2), Intersect(.Rows(i), Columns("A:G")))  'For matched item, union this row with previous value
               Exit For
            End If
        Next j
    Next i
    For i = 1 To UBound(arrSheet, 1)
        If arrSheet(i, 1) <> "Data" Then
           arrSheet(i, 2).Copy Worksheets(arrSheet(i, 1)).Range("A1")  'Copy each item to corresponding sheet
        End If
    Next i
  End With
End Sub

Regards