Option Explicit
 
Sub test()
'    ---------------------------------------
    'Dim iConnection As ADODB.Connection
    'Dim iRecordset As ADODB.Recordset
    Dim iConnection As Object
    Dim iRecordset As Object
    Dim book As Workbook, sht As Worksheet
    Dim coll As Collection, iPath$, i&, arr()
    Dim isht As Worksheet, ikey, cnct$, iSelect$
    Dim iColumnName$, shtname$
'    ---------------------------------------
    Set coll = New Collection
    'Set iConnection = New ADODB.Connection
    'Set iRecordset = New ADODB.Recordset
    Set iConnection = CreateObject("ADODB.Connection")
    Set iRecordset = CreateObject("ADODB.Recordset")
    
    Set book = ThisWorkbook
    Set sht = book.Worksheets("Лист1")
    iPath = ThisWorkbook.Path & Application.PathSeparator & book.Name
    cnct = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & iPath & ";Extended Properties='Excel 12.0;HDR=YES';"
    iConnection.ConnectionString = cnct
    iColumnName = sht.[b1].Value
    On Error Resume Next
        For i = 2 To sht.Range("b" & sht.Rows.Count).End(xlUp).Row
            With sht
                coll.Add .Range("b" & i).Value, .Range("b" & i).Value
            End With
        Next i
    On Error GoTo 0
    Application.ScreenUpdating = False
    For Each ikey In coll
        iConnection.Open
        iSelect = "SELECT * FROM [" & sht.Name & "$] WHERE [" & iColumnName & "]= '" & ikey & "'"
        iRecordset.Open iSelect, iConnection
        Set isht = Worksheets.Add(after:=sht)
        shtname = iReplace(ikey)
        With isht
            .Name = Left(shtname, 30)
            sht.Rows(1).Copy .Rows(1)
           .Range("a2").CopyFromRecordset iRecordset
           .Columns.AutoFit
        End With
        iConnection.Close
    Next ikey
    Application.ScreenUpdating = True
    MsgBox "Готово!"
End Sub

Function iReplace(ikey)
    Dim arr(), lkey
    arr = Array(":", "|", "\", "/", "[", "]", "?", "#", "*")
    For Each lkey In arr
        ikey = Replace(ikey, lkey, "_")
    Next lkey
    iReplace = ikey
End Function