Как сохранить данные из одного в файла в несколько

Option Explicit
Sub XLS_AddSheets_AddFile_RD()
'==============================================================================
'* Автор R Dmitry (Дмитрий Русак [email]dg_rusak@mail.ru[/email] skype: RDG_Dmitry)          |
'* WM:_R269866874234 U144446690328                                            |
'==============================================================================
Dim oCn As Object, oCmd As Object, oDict As Object, sCon$, sWhere$
Dim FieldName$, FilePath$, OutputPath$, sSql$, sTbl$, a, i&
Set oCn = CreateObject("ADODB.Connection")
Set oCmd = CreateObject("ADODB.Command")
On Error GoTo Err_XLS_AddSheets_AddFile_RD
Rem ===============ПАРАМЕТРЫ===========================
FieldName = "Yes" '"No"
FilePath = ThisWorkbook.FullName
'sWhere = "Иванов"
OutputPath = ThisWorkbook.Path
sTbl = "Лист1$A1:B7"
a = Range("A1:B7").Value
Rem ==================================================
Set oDict = CreateObject("scripting.dictionary")
Select Case Val(Application.Version)
        Case Is < 12
            sCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FilePath _
              & ";Extended Properties=""Excel 8.0;HDR=" & FieldName & ";IMEX=1"";"
        Case Else
            sCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FilePath _
            & ";Extended Properties=""Excel 12.0;HDR=" & FieldName & ";IMEX=1"";"
    End Select
oCn.Open sCon
   With oCmd
   For i = 2 To UBound(a)
        If Not oDict.exists(CStr(a(i, 1))) Then
            oDict.Add CStr(a(i, 1)), i
            sWhere = a(i, 1)
            sSql = "SELECT * INTO [sh] IN '" & OutputPath & "\" & sWhere & ".xls' [Excel 8.0;] FROM [" & sTbl & "" _
                  & "] WHERE [ФИО]='" & sWhere & "'"
             .ActiveConnection = oCn
             .CommandText = sSql
             .Execute
         End If
        Next
   End With
 
Exit_XLS_AddSheets_AddFile_RD:
If oCn.State = 1 Then oCn.Close
Set oCn = Nothing: Set oCmd = Nothing
    Exit Sub
 
Err_XLS_AddSheets_AddFile_RD:
    MsgBox Err.Description
    Resume Exit_XLS_AddSheets_AddFile_RD
End Sub