Sub DD()
For I = 1 To 19
If Sheets("Лист4").Cells(I, "a") = "A" And Sheets("Лист4").Cells(I, "b") = "00" And Sheets("Лист4").Cells(I, "L") = "C" Then Sheets("Лист5").Cells(1, "b") = Cells(1, "B").Value & Sheets("Лист4").Cells(I, "K") & "+"
Next
End Sub

Sub delitant90()
    Dim f As Boolean, a, s, st As String
    a = Split(CreateObject("Scripting.FileSystemObject").Getfile("C:\ККК.txt").OpenasTextStream(1).ReadAll, vbNewLine)
    st = "Funds Transfer Amount"
    For Each s In a
      If InStr(1, s, st) > 0 Then
         f = True
         s = Trim$(Replace$(Replace$(s, st, ""), vbTab, ""))
         Exit For
      End If
    Next
    MsgBox IIf(f, s, "not found")
End Sub

Public Sub PutOnClipboard(Obj As Variant)
    Dim MyDataObj As New DataObject
    Dim dat As Date
    dat = Date
    MyDataObj.SetText Format(Obj)
    MyDataObj.PutInClipboard
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 If Not Intersect(Target, Range("a1:a10")) Is Nothing Or Not Intersect(Target, Range("h1:h10")) Is Nothing Then
  Dim dat As Date
 dat = Date
 Target.Cells.Offset(, 1) = dat
    If Target.Cells.Count < 1 Then Exit Sub
    Application.EnableEvents = False
    Dim tCell As Variant
    Dim Temp As Variant
    On Error GoTo Error:
    For Each tCell In Selection.SpecialCells(xlConstants, 23)
        Temp = Temp + tCell.Value
    Next tCell
    PutOnClipboard (Temp)
    'MsgBox "В буфер скопированна сумма выделенных ячеек: " & Temp
    Application.EnableEvents = True
 End If
    Exit Sub
Error:
    MsgBox "Не удалось подсчитать сумму выделенных ячеек"
    'ClearClipboard 'разкоментировать строку если нужно очиститиь буфер при ошибке
    Application.EnableEvents = True
End Sub
Public Sub ClearClipboard()
   Dim MyDataObj As New DataObject
   MyDataObj.SetText ""
   MyDataObj.PutInClipboard
End Sub

Sub TEST()
    Application.ScreenUpdating = False
    With Sheets("ALLRESULTS")
        .AutoFilterMode = 0
        .Range("$A$1:$I$400").AutoFilter 1, Array( _
                 "parametrV", "parametrU"), Operator:=xlFilterValues
        .Range("$A$1:$I$400").AutoFilter 3, "=26", _
                Operator:=xlOr, Criteria2:="=05"
    .Range("$A$2:$I$400").SpecialCells(12).Copy Sheets("TOTAL").Range("A1")
End With
    Application.ScreenUpdating = True
End Sub

=СУММЕСЛИМН(D:D;A:A;"parametr1";A:A;"parametr2";A:A;"parametr3";C:C;"05";C:C;"26")

Sub CloseAllWorkbooks2()
'ВВЕЛА ПЕРЕМЕННЫЕ'
DIM B 'АДРЕС КУДА СОХРАНЯТЬ'
DIM I 'ЯЧЕЙКА ИЗ КОТОРОЙ БУДЕМ БРАТЬ ИМЯ С КОТОРЫМ СОХРАНЯЕТСЯ ЗАКРЫВАЕМАЯ КНИГА'
b="С:\отчеты\"
i=B4
 ' закрываем все книги, кроме той, из которой запущен макрос
    Dim wb As Workbook: Application.ScreenUpdating = False
    For Each wb In Workbooks    ' перебираем все открытые книги
        If Not wb Is ThisWorkbook Then If wb.Windows(1).Visible Then wb.saveAs filename:="B & I"
    Next wb
End SuB

Sub CloseAllWorkbooks2()
    ' закрываем все книги, кроме той, из которой запущен макрос
    Dim wb As Workbook: Application.ScreenUpdating = False
    For Each wb In Workbooks    ' перебираем все открытые книги
        If Not wb Is ThisWorkbook Then If wb.Windows(1).Visible Then wb.Close
    Next wb
End Sub

For r = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    Cells(r, 2) = Dir(Cells(1, 1) & Cells(r, 1))
    adr = Cells(1, 1)
Workbooks.Open Filename:=adr & Cells(r, 2)

Sub FileChecker()
  Dim r As Long
  Dim sShName As String, sAddress As String, vData
'цикл проверки наличия файла
  For r = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    Cells(r, 2) = Dir(Cells(1, 1) & Cells(r, 1))
    adr = Cells(1, 1)
Workbooks.Open Filename:=adr & Cells(r, 2)
    
    'начинается макрос копирования диапазона из файла в книгу endreport
    sAddress = "A1:C100" 'или одна ячейка - "A1"
    'получаем значение
    vData = Sheets("1").Range(sAddress).Value
    ActiveWorkbook.Close False
   Sheets("12").Select
    If IsArray(vData) Then
        [A1].Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
    Else
        [A1] = vData
    End If
    'макрос копирования заканчивается
  'далее: происходит сценарий(он неважен)над скопированным диапазоном - далее происходит очистка всех листов
  
  Next 'переход к проверке наличия следующего файла
End Sub

Sub TEST()
Application.ScreenUpdating = False
'TOTAL'
Sheets("ALLRESULTS").Select
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.AutoFilter
Sheets("ALLRESULTS").Range("$A$1:$I$400").AutoFilter Field:=1, Criteria1:=Array( _
 "parametr5", "parametr6", "parametr8", "parametr7"), Operator:=xlFilterValues
Sheets("ALLRESULTS").Range("$A$1:$I$400").AutoFilter Field:=3, Criteria1:="=26", _
Operator:=xlOr, Criteria2:="=05"
Selection.Copy
Sheets("TOTAL").Select
Range("A1").Select
ActiveSheet.Paste
Application.ScreenUpdating = True

End Sub

Sub test()
Dim Dat As Date, Dat1 As Date, I As Long, J As Long
Dat = Date 'системная дата'
'дата  для согласования с текущими данными'
'когда будут реальные данные по дате - этот оператор надо убрать'
Dat = CDate("08.09.2016")
I = 14
J = 1
Workbooks("Report2.xlsx").Activate
Sheets(1).Activate
iLastRow = Cells.Find("*", [A1], SearchDirection:=xlPrevious).Row
With Workbooks("Report1.xlsm").Sheets(1)
  Do While IsDate(.Range("B" & I))
    Dat1 = .Range("B" & I)
    If Dat1 = Dat - 1 Then
      .Range("B" & I & ":G" & I).Copy
      Range("A" & J).Select
      ActiveSheet.Paste
      J = J + 1
    End If
    I = I + 1
  Loop
End With
End Sub