If b(i,5)<>"" then
действие
End if

If b(i,5) <>"" and iserror b(i,5) =false then

Sub mass()
fldr = "C:\"
s = "testdata-1000.csv"

b = TextFile2Array(, fldr, , s)
End sub
____________________________
Function TextFile2Array(Optional ByVal Title As String = "Выберите файл для обработки", _
                        Optional ByVal InitialPath As String = "c:\", _
                        Optional ByVal FilterDescription As String = "Текстовые файлы", _
                        Optional ByVal FilterExtention As String = "*.*", _
                        Optional ByVal ColumnsSeparator$ = ";", _
                        Optional ByVal RowsSeparator$ = "?") As Variant 'какой должен быть разделитель строк?

    On Error Resume Next

    With Application.FileDialog(msoFileDialogOpen)    ' диалоговое окно выбора файла CSV
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
        .Filters.Clear: .Filters.Add FilterDescription, FilterExtention
        If .Show <> -1 Then Exit Function
        filename$ = .SelectedItems(1)
    End With
    Set FSO = CreateObject("scripting.filesystemobject")    ' читаем текст из выбранного файла
    Set ts = FSO.OpenTextFile(filename$, 1, True): txt$ = ts.ReadAll: ts.Close
    Set ts = Nothing: Set FSO = Nothing
    txt = Trim(txt): Err.Clear    ' разделяем текст на строки и столбцы
    If txt Like "*" & RowsSeparator$ Then txt = Left(txt, Len(txt) - Len(RowsSeparator$))
    tmpArr1 = Split(txt, RowsSeparator$): RowsCount = UBound(tmpArr1) + 1
    ColumnsCount = UBound(Split(tmpArr1(0), ColumnsSeparator$)) + 1
    If Err.Number > 0 Then MsgBox "Строка не может быть разбита на двумерный массив", vbCritical: End
    ReDim arr(1 To RowsCount, 1 To ColumnsCount)
    For i = LBound(tmpArr1) To UBound(tmpArr1)
        tmpArr2 = Split(Trim(tmpArr1(i)), ColumnsSeparator$)
        For j = 1 To UBound(tmpArr2) + 1
            arr(i + 1, j) = tmpArr2(j - 1)
        Next j
    Next i
    TextFile2Array = arr    ' возвращаем результат в виде двумерного массива
End Function

Set x = Workbooks(xFile).Worksheets(xsheet).Rows(1).find("Поставщик", , xlFormulas, xlWhole)
   x1 = x.Column
 Cells(2, x1).FormulaR1C1 = "=VLOOKUP(C1,'[" & "Расчет_общий.xlsb" & "]" & xsheets & "'!C1:C8,8,0)" 
...
Application.Calculation = xlCalculationManual
Range("H2:S2").AutoFill Destination:=Range("H2:S" & xlastrow)
Application.Calculation = xlCalculationAutomatic
Range("H2:S" & xlastrow).Value = Range("H2:S" & xlastrow).Value

For i=1 to lastrow  
For i1=1 to lastrow2   
If cells(i,1)=cells(i1,1) then   
cells(i,10)=cells(i1,18) and _   
cells(i,12)=cells(i1,22) and _   
....   
End if  
Next i1
Next i

For i = 0 to 1000
  If b(56,i)="DRINK" then
    Workbooks("test").worksheets("test").range(cells(lr,1),cells(lr,lc))= range(b(0,i),b(135,i)) 'что-то вроде этого мне нужно
  End if
Next

Sub mal_da_udal()
Dim lr As Long

lr = Sheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row

For a = lr To 2 Step -1
  If Cells(a, 1) Like "*доб*" Then
   If Not Cells(a, 1) Like "*доб*/" Then
     Rows(a).Delete
   End If
  End If
Next

End Sub

Sub perebor()
Dim db As Database
Dim rs As Recordset
Dim lngRecordCount As Long

Set db = CurrentDb
Set rs = db.OpenRecordset("q_promoexcel", dbOpenDynaset)
If rs.RecordCount <> 0 Then
rs.MoveLast

lngRecordCount = rs.RecordCount
rs.MoveFirst

     For i = 4 To lngRecordCount
       If rs(i,1) = rs(i-1,1) then rs(i,3) = rs(i-1,2)+rs(i,2) 'как обратиться к этим ячейкам правильно?
     Next

        rs.Close
        db.Close

End Sub

Sub Access()
Dim s As String, fldr As String
Dim dbsNorthwind As Database
Dim rstEmployees As Recordset
Dim strMessage As String
Dim b As Variant

Set dbsNorthwind = OpenDatabase("C:\OP.accdb")
Set rstEmployees = dbsNorthwind.OpenRecordset("SELECT * FROM q_promoexcel")
    b = rstEmployees.GetRows(rstEmployees.RecordCount)
     b = TransposeArray(b)
End sub
_______________________________________________________________________________________

Function TransposeArray(ByVal arr As Variant) As Variant
    Dim tempArray As Variant
    ReDim tempArray(LBound(arr, 2) To UBound(arr, 2), LBound(arr, 1) To UBound(arr, 1))
    For x = LBound(arr, 2) To UBound(arr, 2)
        For y = LBound(arr, 1) To UBound(arr, 1)
            tempArray(x, y) = arr(y, x)
        Next y
    Next x
    TransposeArray = tempArray
End Function

Sub access()
   Dim cn As Object, rs As Object
   Dim intColIndex As Integer
   Dim DBFullName As String
   Dim TargetRange As Range
    
    DBFullName = "C:\OP.accdb"
    Set TargetRange = Sheets("Лист1").Range("B2")
    Set cn = CreateObject("ADODB.Connection")
    cn.Open "Provider=Microsoft ActiveX Data Objects 6.1 Library; Data Source=" & DBFullName & ";"
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open "SELECT * FROM q_promoexcel", cn, , , adCmdText
    For intColIndex = 0 To rs.Fields.Count - 1
    TargetRange.Offset(1, intColIndex).Value = rs.Fields(intColIndex).Name
    Next
    
     On Error Resume Next
     appAccess.Close
     Set appAccess = Nothing
     cn.Close
     Set cn = Nothing
End sub

Sub as()
Dim a As Long
Dim b As Long
Dim lastrowdata as long
Dim ch As Integer
lastrowdata= Cells(Rows.count, 1).End(xlUp).Row
ch = 0
For b = 2 To a
  For a = 2 To lastrowData
    If b <> a And Cells(a, 4) <> Cells(b, 4) Then ch = ch + 1
  Next
Next
Cells(lastrowData + 1, 4).Value = ch
End sub

Sub perebor()
Dim s As String, fldr As String
'fldr = "C:\путь к файлу"
s = Dir(fldr & "файл *.xlsm")
Do While s <> ""
    With Workbooks.Open(fldr & s)
    ActiveWorkbook.RefreshAll
        lr = Worksheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row
        lc = Worksheets("Лист1").Cells(1, Columns.Count).End(xlToLeft).Column

        Range(Cells(2, 9), Cells(lr, 9)).Clear
        R_data = Worksheets("Лист1").Range(Worksheets("Лист1").Cells(1, 1), Worksheets("Лист1").Cells(lr, lc))
        вычисления
        Worksheets("Лист1").Cells.Delete
        Worksheets("Лист1").Range(Worksheets("Лист1").Cells(1, 1), Worksheets("Лист1").Cells(lr, lc)) = R_data
        ActiveSheet.ListObjects.Add(xlSrcRange, Range(Cells(1, 1), Cells(lr, lc)), , xlYes).Name = "Таблица2"
        ActiveWorkbook.Save  'на этой строке выдает окно из скриншота.
        ActiveWorkbook.Close
    End With
    s = Dir
Loop
End Sub

Sub poisk_file_perviy_svezest()
Dim wb As Workbook

СамыйСвежийФайл$ = LastFile$("С:\путь\", ".xlsb")
Set wb = Workbooks.Open(СамыйСвежийФайл$)
_________________________________________________________________________________________________
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
                                 ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then
        Application.StatusBar = "поиск в папке: " & FolderPath
 
        For Each fil In curfold.Files
            If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
        Next
        SearchDeep = SearchDeep - 1
        If SearchDeep Then
            For Each sfol In curfold.SubFolders
                GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
            Next
        End If
        Set fil = Nothing: Set curfold = Nothing
    End If
End Function

Dim x
Dim lr As Long
lr = .Cells(1, 1).End(xlUp).Row + 1
  For each x in Me.Controls    'эту строку нужно изменить, чтобы цикл ходил по чекбоксам по очереди
    If TypeOf x Is MSForms.CheckBox Then
      If x = True Then
        .Cells(lr, 1).Value = frmKust1.Value
        .Cells(lr, 3) = rcNow1.Value
        .Cells(lr, 4).Value = rcTo1.Value
          If x = FlowSwitcherForm.cat_sh_1 Then Cells(lr, 2) = "S"
          If x = FlowSwitcherForm.cat_fr_1 Then Cells(lr, 2) = "F"
          If x = FlowSwitcherForm.cat_alc_1 = True Then Cells(lr, 2) = "A"
          If x = FlowSwitcherForm.cat_of_1 = True Then Cells(lr, 2) = "FV"
          If x = FlowSwitcherForm.cat_z_1 = True Then Cells(lr, 2) = "Fr"
          lr = lr + 1
      End If
    End If
  Next

Public sub cb()
Dim cb As Integer
cb = 0
If FlowSwitcherForm.cat_fr_1 <> "" Then
    cb = cb + 1
End If
If FlowSwitcherForm.cat_sh_1 <> "" Then
    cb = cb + 1
End If
If FlowSwitcherForm.cat_alc_1 <> "" Then
    cb = cb + 1
End If
If FlowSwitcherForm.cat_of_1 <> "" Then
    cb = cb + 1
End If
If FlowSwitcherForm.cat_z_1 <> "" Then
    cb = cb + 1
End If
With Worksheets("Расчет")
fr = Range("A1").End(xlDown)
  If cb = 1 Then
    Cells(fr, 1) = FlowSwitcherForm.frmKust1 And Cells(fr, 3) = FlowSwitcherForm.rcNow1 And Cells(fr, 3) = FlowSwitcherForm.rcTo1 And Cells(fr, 2) = cb.Value
  End If
End With

Sub poisk_file_perviy_svezest()
Dim lr As Long
Dim lr2 As Long

СамыйСвежийФайл$ = LastFile$("C:\", ".xlsb")
    Workbooks.Open СамыйСвежийФайл$
lr = Workbooks("stock_report*.xlsb").Worksheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row
lr2 = Workbooks("Книга2.xlsx").Worksheets("Лист1").Cells(Rows.Count, 1).End(xlUp).Row

___________________________________________________________________________________________________________
Function LastFile$(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
                   Optional ByVal SearchDeep As Long = 999)
   
    Dim FilenamesCollection As New Collection
    Set FSO = CreateObject("Scripting.FileSystemObject")
    GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep
    Set FSO = Nothing: Application.StatusBar = False
    Dim maxFileDate As Double
    For Each file In FilenamesCollection
        currFileDate = FileDateTime(file)
        If currFileDate > maxFileDate Then LastFile$ = file: maxFileDate = currFileDate
    Next file
End Function
___________________________________________________________________________________________________________ 
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
                                 ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then
        Application.StatusBar = "поиск в папке: " & FolderPath
 
        For Each fil In curfold.Files
            If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
        Next
        SearchDeep = SearchDeep - 1
        If SearchDeep Then
            For Each sfol In curfold.SubFolders
                GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
            Next
        End If
        Set fil = Nothing: Set curfold = Nothing
    End If
End Function

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveWorkbook.ActiveSheet.DisplayPageBreaks = False

Dim nagruzName As String
nagruzName = Worksheets("Лист1").Cells(1, 5)
otvet = MsgBox("Имя книги: " & nagruzName & " ?", vbYesNo)

Dim fullname As String
Application.ScreenUpdating = False
fullname = "W:\" & nagruzName & ".xlsb"
Select Case otvet
    Case vbYes
    On Error Resume Next
           Workbooks.Open fullname
    Case vbNo
           nagruzName = InputBox("Введите имя книги")
             If nagruzName = "" Then
               Exit Sub
             End If
On Error Resume Next
fullname = "W:\" & nagruzName & ".xlsb"
           Workbooks.Open fullname
           Workbooks("Книга1.xlsm").Worksheets("Лист1").Cells(1, 5) = nagruzName
End Select

Sub peresech()
Dim w As Range
Dim rng1 As Range
Dim rng2 As Range
With Worksheets("Лист1")
Set rng1 = Rows(1).Find(what:="5", LookIn:=xlValues, lookAt:=xlWhole)
Set w = Columns(1).Find(what:="30", LookIn:=xlValues, lookAt:=xlWhole)
Set rng2 = Columns(1).Find(what:="3", after:=w, LookIn:=xlValues, lookAt:=xlWhole)
End With
With Worksheets("Лист2")
ActiveCell.Value = Intersect(rng2, rng1)
End With
End Sub

lastrow = Sheets("лист1").Cells(Rows.Count, 1).End(xlUp).Row
u = True
  For m1 = 2 To lastrow
    If Cells(m1, 7).SpecialCells(xlCellTypeVisible) <> "" Then
    u = False
  Exit For
    End If
  Next m1
    If u = True Then
    ActiveSheet.AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete

    lastrow = Cells(3, 5).End(xlDown).Row + 1
    result.Range("result").SpecialCells(xlCellTypeVisible).Copy
    finalWB.Cells(lastrow, 1).PasteSpecial Paste:=xlPasteValues
    lastRowLast = Cells(3, 5).End(xlDown).Row
    finalWB.Range("M" & lastrow - 1 & ":AA" & lastrow - 1).AutoFill Destination:=finalWB.Range("M" & lastrow - 1 & ":AA" & lastRowLast), Type:=xlFillDefault
    finalWB.Range("B" & lastrow & ":L" & lastRowLast).Borders.LineStyle = finalWB.Range("B" & lastrow - 1).Borders.LineStyle