Stroka = Stroka & ListBox1.List(i, 0) & " " & CDate(ListBox1.List(i, 1)) & " " & ListBox1.List(i, 2) & " " & ListBox1.List(i, 3) & " " & ListBox1.List(i, 4) & " " & ListBox1.List(i, 5) & " " & ListBox1.List(i, 6) & " " & ListBox1.List(i, 7) & " " & ListBox1.List(i, & "" & "/" & Chr(10)
  

Sub Poisk()Dim cell As Range,cellsDel As Range, cellAddress As String
With Workbooks("Книга1.xlsx").Sheets("Лист2").cells(6, Columns.Count).End(xlToLeft).Column.UsedRange ' ЗДЕСЬ, КАК Я ПОНИМАЮ, НУЖНО УКАЗАТЬ, ГДЕ ИСКАТЬ. УКАЗАЛ

' ЗДЕСЬ, ЧТО ИЩЕМ. УКАЗАЛ  Set cell = .Find(Workbooks("Книга1.xlsx").Sheets("Лист1").Range("H2")) 'ищем первую попавшуЮсяIf Not cell Is Nothing Then 'если нашлиSet cellsDel = cell.Resize(2) 'сохраняем в переменную, увеличенную до 2 строк (Resize(2)) 'МНЕ НИЧЕГО УВЕЛИЧИВАТЬ НЕ НАДО
cellAddress = cell.Address 'запоминаем адрес, потому что FindNext будет искать по кругу и ее надо будет остановить
Do
Set cell = .FindNext(cell) 'продолжаем поиск после ячейки cell
If Not cell Is Nothing Then Set cellsDel = Union(cellsDel, cell.Resize(2)) 'если нашли, то добавляем в cellsDel ЗДЕСЬ ТОЖЕ ДВОЙКА В КОНЦЕ СМУЩАЕТ - УВЕЛИЧИВАТЬ НИЧЕГО НЕ НУЖНО      'DoEvents 'эту штуку можно ставить на стадии отладки, чтоб можно остановить Do...Loop в случае косяка
Loop Until cellAddress = cell.Address 'если дошли до адреса который уже был, выпадаем из Do...Loop
cellsDel.EntireRow.Delete 'удаляем строки принадлежащие ячейкам в переменной cellsDel МНЕ НЕ НУЖНО УДАЛЯТЬ - 'НУЖНО НОМЕРА КОЛОНОК СО ВСЕМИ НАЙДЕННЫМИ ЗНАЧЕНИЯМИ ВЫСТРОИТЬ В СТОЛБИК НА ЛИСТЕ Workbooks("Книга1.xlsx").Sheets("Лист1"), НАЧИНАЯ С ЯЧЕЙКИ I1.
End If
End With
End sub
' КОД БУДЕТ НАХОДИТЬСЯ В КНИГЕ Книга2.xlsb

Workbooks("Книга1.xlsb").Worksheets("Лист1").[B2].FormulaR1C1 = _
"=ЕСЛИОШИБКА(ИНДЕКС('C:\Users\" & Workbooks("Книга1.xlsb").Worksheets("Лист2").[A1] _
& "\OneDrive\Общие\[Сеть.xlsb]Данные'!$D:$D;ПОИСКПОЗ($B$1;'C:\Users\" _
& Workbooks("Книга1.xlsb").Worksheets("Лист2").[A1] & "\OneDrive\Общие\[Сеть.xlsb]Данные'!$A:$A;0));"""")"

Sub Find_n_Highlight()
    On Error Resume Next: Err.Clear
    Dim ra As Range, cell As Range, res, txt$, v, pos&
    res = Workbooks("7.0.xlsb").Sheets("Сдан").Range("C2")
    If VarType(res) = vbBoolean Then Exit Sub    ' нажата кнопка ОТМЕНА
    txt$ = Trim(res): If Len(txt) = 0 Then Exit Sub    ' текст не введен, или состоит из пробелов    
    Set ra = Workbooks("Сеть7.xlsb").Sheets("Срас").Range([P2], Range("P" & Rows.Count).End(xlUp))    ' диапазон для поиска
    Application.ScreenUpdating = False
    ra.Font.Color = 0: ra.Font.Bold = 0  ' сброс цветового выделения    
    For Each cell In ra.Cells    ' перебираем все ячейки
        pos = 1
        If cell.Text Like "*" & txt & "*" Then
            arr = Split(cell.Text, txt, , vbTextCompare)   ' разбивает текст ячейки на части
            If UBound(arr) > 0 Then    ' если подстрока найдена
                For Each v In arr    ' перебираем все вхождения
                    pos = pos + Len(v)    ' начальная позиция
                    With cell.Characters(pos, Len(txt))
                        .Font.ColorIndex = 3    ' выделяем цветом
                        .Font.Bold = True    ' и полужирным начертанием
                    End With
                    pos = pos + Len(txt)
                Next v
            End If
        End If
    Next cell
End Sub