Sub Example2()
off_ ' Отключаем пересчет формул, диалоги и обновление экрана
     Dim rngAdr$
     Dim ADO As New ADO
     Dim tResArr
     Dim i&, v&
          
     rngAdr = Range("A4:B" & [A1000000].End(xlUp).Row).Address(0, 0, 1, 0) ' определяем в переменную адрес диапазона
     ADO.DataSource = ThisWorkbook.Path & "\" & ThisWorkbook.Name ' Указываем источник
     ADO.Query ("SELECT DISTINCT F1, F2 FROM [СМ$" & rngAdr & "] WHERE F1 <> '' AND F2 <> ''") ' Собственно, сам запрос SQL к листу книги, который выбирает уникальные пары значений первых двух столбцов
     tResArr = ADO.ToArray() ' Результат выводим в массив
      
     For i = 1 To UBound(tResArr) 'проходим по массиву
         ' Следующий запрос берет уникальные пары значений и выбирает все записи с листа, соответствующие этим парам
         ADO.Query ("SELECT * FROM [СМ$" & rngAdr & "] WHERE F1 = '" & tResArr(i, 1) & "' AND F2 = '" & tResArr(i, 2) & "';") '
          
         Sheets.Add 'Добавляем новый лист
         With ActiveSheet
             .Name = tResArr(i, 1) ' обзываем его первым значением из пары
             .[a1].CopyFromRecordset ADO.Recordset ' выводим результат запроса на новый лист
             .Move 'перемещаем его в новую книгу
             ' Обзываем файл вторым значением из пары, предварительно заменив запрещенные символы и сохраняем его в папку с исходным файлом
             ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & tResArr(i, 1) & "_" & replPunct(tResArr(i, 2))
             ActiveWorkbook.Close False 'закрываем свежеиспеченную книгу
         End With
     Next
     
on_ 'Включаем пересчет формул, диалоги и обновление экрана
MsgBox "Все готово!", vbOKOnly
End Sub

Sub off_()
     With Application
         .DisplayAlerts = False
         .ScreenUpdating = False
         .Calculation = xlCalculationManual
     End With
End Sub

Sub on_()
     With Application
         .DisplayAlerts = True
         .ScreenUpdating = True
         .Calculation = xlCalculationAutomatic
     End With
End Sub

Function replPunct$(ByVal t$)
     t = Replace(t, """", "")
     t = Replace(t, "~*", "")
     t = Replace(t, "\", "")
     t = Replace(t, "/", "")
     t = Replace(t, ":", "")
     t = Replace(t, "<", "")
     t = Replace(t, ">", "")
     t = Replace(t, "~?", "")
     replPunct = t
End Function