r = [a1:b18]: l = ""
For i = 2 To UBound(r)
    If l <> r(i, 2) Then
        l = r(i, 2)
        Set SH = Sheets.Add(After:=Sheets(Sheets.Count))
        SH.Name = l
        SH.Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1) = r(i, 1)
    Else
        SH.Cells(Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) = r(i, 1)
    End If
Next

Sub RaznestiDannye()
Dim i As Long
Dim n As Long
Dim Criterij As String
Dim iName As String
Dim Sht As Worksheet
Application.ScreenUpdating = False
  Set Sht = ThisWorkbook.Worksheets("Лист1")
        Columns("D").ClearContents
     'отбор уникальных значений столбца B в столбец D
    Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy _
                                  , CopyToRange:=Range("D1"), Unique:=True
     'количество уникальных значений ID
      n = Cells(Rows.Count, "D").End(xlUp).Row
    For i = 2 To n          'цикл по уникальным значениям
        Criterij = Sht.Cells(i, "D")
        iName = Criterij    'имя нового листа
     'создаем новый лист
       Worksheets.Add After:=Worksheets(Worksheets.Count)
     'ставим автофильтр по столбцу B
       Sht.Range("A1:B18").AutoFilter 2, Criterij
     'копируем видимые строки в новый лист
        Sht.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy
        With Worksheets(Worksheets.Count)
          .Range("A1").PasteSpecial xlPasteColumnWidths
          .Range("A1").PasteSpecial xlPasteFormats
          .Range("A1").PasteSpecial xlPasteValues
          Sht.AutoFilter.Range.AutoFilter
          .Name = iName
          .Range("A1").Select
        End With
    Next
        Sht.Columns("D").ClearContents
Application.ScreenUpdating = True
End Sub