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

Sub mrshkei()
Workbooks("Больше ноля.xlsm").Activate
Sheets("Лист1").Select
Dim arr, i As Long, lr As Long
lcol = Cells(2, Columns.Count).End(xlToLeft).Column
ReDim arr(1 To 1)
For i = 2 To lcol Step 3
    If Cells(2, i) > 0.01 Then arr(UBound(arr)) = Cells(2, i).Address: ReDim Preserve arr(1 To UBound(arr) + 1)
Next i
Sheets("Лист2").Range("A1").Resize(UBound(arr), 1) = Application.WorksheetFunction.Transpose(arr)
End Sub

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));"""")"