Sub RaznestiDannye()
Dim i As Long
Dim Criterij As String
Dim iName As String
Dim WbN As Workbook
Dim Autofilter As Autofilter
Dim iLastRow As Long
  iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Columns("H").ClearContents
      'уникальные из F в столбец H
  Range("F1:F" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("H1"), Unique:=True
     iLastRow = Cells(Rows.Count, "H").End(xlUp).Row
    For i = 2 To iLastRow          'цикл по уникальным номерам
        Criterij = Worksheets("Лист1").Cells(i, "H")
        iName = Criterij    'имя новой книги
    'создаем новую книгу с одним листом
    Set WbN = Workbooks.Add(xlWBATWorksheet)
    ThisWorkbook.Worksheets("Лист1").Activate
    'ставим автофильтр по столбцу J
        Range("A1").CurrentRegion.Autofilter 6, Criterij
    'копируем видимые строки в новую книгу
        ActiveSheet.Autofilter.Range.SpecialCells(xlCellTypeVisible).Copy WbN.Sheets("Лист1").Range("A1")
        ActiveSheet.Autofilter.Range.Autofilter
        
        WbN.Sheets("Лист1").Columns("A:F").AutoFit
        WbN.SaveAs ThisWorkbook.Path & "\" & iName & ".xls"
        WbN.Close SaveChanges:=True
    Next
  Columns("H").ClearContents
Application.ScreenUpdating = True
End Sub