Множественный поиск значений из Access в книге Excel

Option Compare Database
Option Explicit
 
Dim app As Object
Dim Workbooks As Object
 
Dim strPathExcel As String
Dim xlWbk As Object
Dim ns
Dim xlApp As Object
Public Rowss As Integer, Rowss2 As Integer
 
Const MyFile = "P:\дела\ДЕЛА 2015 ОПОСД.xls"
Const l = "Сводная таблица_2015г" 'l = "Лист1" 'можно просто цифрой номер листа указывать
 
Sub Delo_v_Excel_Poisk_2()
Dim sRowNumber
Dim Poisk1, Poisk2
 
Set xlApp = CreateObject("Excel.Application.14") 'создаем объект Excel, чтобы можно было работать с его методами и свойствами
strPathExcel = MyFile
Set xlWbk = xlApp.Workbooks.Open(strPathExcel)
 
Poisk1 = Forms!Данные![Краткое наименование]
Poisk2 = ((Forms!Данные.Сумма_долга) + (Forms!Данные.Сумма_процентов))
 
sRowNumber=xlWbk.Worksheets(l).Cells.Find(What:=Poisk1, LookAt:=xlWhole).Row

Option Compare Database
Option Explicit
 
Dim app As Object
Dim Workbooks As Object
 
Dim strPathExcel As String
Dim xlWbk As Object
Dim ns
Dim xlApp As Object
Public Rowss As Integer, Rowss2 As Integer
 
Const MyFile = "P:\Судебные дела\СУДЕБНЫЕ ДЕЛА 2015 ОПОСД.xls"
Const l = "Сводная таблица_2015г" 'l = "Лист1" 'можно просто цифрой номер листа указывать
 
Sub Poisk_strok()
 
Dim F1, F2
Dim txt, КоличествоСтрок%
 
F1 = Forms!Данные!Краткое_наименование
 
    txt = Trim(F1): If Len(txt) = 0 Then Exit Sub    ' если текст не введён
    КоличествоСтрок% = ПоискСтрокПоУсловию(txt)
    If КоличествоСтрок% > 0 Then
        MsgBox "Найдено строк: " & КоличествоСтрок%
    Else
        MsgBox "подходящих строк не надено! "
    End If
End Sub
 
Function ПоискСтрокПоУсловию(ByVal ТекстДляПоиска As String, Optional HideOnly As Boolean) As Long
    ' функция получает в качестве параметра ТекстДляПоиска (можно использовать символы * и ?)
    ' Если HideOnly = TRUE, то строки, содержащие в ячейках ТекстДляПоиска, скрываются,
    ' иначе (HideOnly = FALSE - по умолчанию) - удаляются
    ' Функция возвращает количество удалённых строк
    Dim ra As Range, delra As Range
    
Set xlApp = CreateObject("Excel.Application.14") 'создаем объект Excel, чтобы можно было работать с его методами и свойствами
strPathExcel = MyFile
Set xlWbk = xlApp.Workbooks.Open(strPathExcel)
    
xlApp.Visible = True 'запускаем приложение Excel
xlApp.ScreenUpdating = False    ' отключаем обновление экрана
 
    ' перебираем все строки в используемом диапазоне листа
    For Each ra In ActiveSheet.UsedRange.Rows
        ' если в строке найден искомый текст
        If Not ra.Find(ТекстДляПоиска, , xlValues, xlPart) Is Nothing Then
            ' добавляем строку в диапазон для удаления
            If delra Is Nothing Then Set delra = ra Else Set delra = Union(delra, ra)
        End If
    Next
    On Error Resume Next: ПоискСтрокПоУсловию = delra.Areas.Count ' количество найденных строк
    
    If Not delra Is Nothing Then    ' если подходящие строки найдены - сообщение с их номером
        For Each ro In delra.EntireRow: MsgBox ro.Row: Next
    End If
End Function

Sub Delo_v_Excel_Poisk_1()
 
Call StatusBarYes
 
Set xlApp = CreateObject("Excel.Application.14") 'создаем объект Excel, чтобы можно было работать с его методами и свойствами
'l = "Лист1" 'можно просто цифрой номер листа указывать
strPathExcel = MyFile
Set xlWbk = xlApp.Workbooks.Open(strPathExcel)
 
Dim S, r, db As DAO.Database, rst As DAO.Recordset
Dim stroka, adr1
 
Set db = CurrentDb
S = "select * from [Лист1$] in '" & MyFile & "'[Excel 12.0; HDR=True;]" 'В предположении что первая строка имя столбца
 
Set rst = db.OpenRecordset(S)
 
r = Range("A1") = Forms!Данные![Краткое наименование] & Range("F3") = (Forms!Данные!Сумма_долга + Forms!Данные!Сумма_процентов)
 
rst.FindFirst r
If rst.NoMatch Then
    MsgBox "Совпадений не найдено"
    Exit Sub
End If
 
stroka = rst.AbsolutePosition + 1 & vbCrLf
'Если совпадения есть, находим их
Do While True
  rst.FindNext r
  If Not rst.NoMatch Then 'Собираем строку сообщения
     stroka = stroka & rst.AbsolutePosition + 1 & vbCrLf
  End If
Loop
 
MsgBox "Значения найдены в строках " & vbCrLf & stroka
xlApp.Visible = True 'запускаем приложение Excel, можно сдвинуть вниз
 
Set app = Nothing 'уничтожаем переменную с объектом
Set xlApp = Nothing
Set xlWbk = Nothing
Set adr1 = Nothing