Передача данных в Access

Public Function ADO_R_Dmitry(ByVal StrSql$, ByVal FilePath$, ByVal OutputRange As Range, _
ByVal FieldsName As Boolean, ByVal OutputFieldsName As Boolean, Optional TypeBase As Long = 0, Optional ColumnDelimeter As String = ",")
 
'==============================================================================
'* Автор R Dmitry
'==============================================================================
Dim sCon As String, FieldName As String
Dim rs As Object, cn  As Object
Set rs = CreateObject("ADODB.Recordset")
Set cn = CreateObject("ADODB.Connection")
If FieldsName Then FieldName = "Yes" Else FieldName = "No"
 
If TypeBase > 0 Then
    sCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
    If TypeBase = 1 Then sCon = sCon & FilePath & ";User Id=admin;Password=;" 'Access
   'If TypeBase = 2 Then sCon = "Driver={Microsoft dBASE Driver (*.dbf)};DriverID=277;Dbq=" & FilePath
    If TypeBase = 2 Then sCon = sCon & FilePath & ";Extended Properties=dBASE IV;User ID=Admin;Password=;" 'DBF
    'If TypeBase = 3 Then sCon = sCon & FilePath & ";Extended Properties=text;HDR=" & FieldName & ";FMT=Delimited " & ColumnDelimeter 'TXT
    If TypeBase = 3 Then sCon = "Driver={Microsoft Text Driver (*.txt; *.csv)};Dbq=" & FilePath & ";Extensions=asc,csv,tab,txt;"
Else
    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 12, 14
            sCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FilePath _
            & ";Extended Properties=""Excel 12.0;HDR=" & FieldName & ";IMEX=1"";"
    End Select
End If
cn.Open sCon
If Not cn.State = 1 Then Exit Function
Set rs = cn.Execute(StrSql)
If Not FieldsName Then OutputFieldsName = False
 If OutputFieldsName Then
    For i = 0 To rs.Fields.Count - 1
    OutputRange.Offset(0, i) = rs.Fields(i).Name
    Next
    Set OutputRange = OutputRange.Offset(1, 0)
 End If
 DoEvents
OutputRange.CopyFromRecordset rs
rs.Close:  cn.Close
Set cn = Nothing: Set rs = Nothing
End Function
Sub test()
Dim strSql2$
Dim Lr&
Lr = Cells(Rows.Count, 1).End(xlUp).Row
If Lr < 3 Then Lr = 3
Range("a3:q" & Lr).ClearContents
strSql2 = "select * from [Янв_Февр$] where [Код товара]like '%" & [a2].Value & "%'"
Call ADO_R_Dmitry(strSql2, ThisWorkbook.FullName, Sheets("Поиск").[a3], True, False)
End Sub
Sub test2()
Dim strSql2$
Dim Lr&
Lr = Cells(Rows.Count, 1).End(xlUp).Row
If Lr < 3 Then Lr = 3
Range("a3:q" & Lr).ClearContents
strSql2 = "select * from [Мар_Апр$] where [Код товара]like '%" & [a2].Value & "%'"
Call ADO_R_Dmitry(strSql2, ThisWorkbook.FullName, Sheets("Поиск").[a3], True, False)
End Sub