Function PS_3_СВОД(iRng As Range, condRng As Range)
Dim arr(), iTmp, tmpStr$
Dim I&, N&
Dim tmpSum%
arr = iRng.Value
ReDim iTmp(1 To UBound(arr, 1)) ', 1 To 1)
For I = LBound(arr, 1) To UBound(arr, 1)
  Select Case I
    Case Is = 1
      For N = 2 To 5: tmpSum = tmpSum + arr(N, 1): Next
      iTmp(I) = IIf(arr(I, 1) = tmpSum, "", I)
      tmpSum = 0
    Case Is = 6
      iTmp(I) = IIf(arr(I, 1) = 0, "", I)
    Case Is = 7
      For N = 8 To 24 Step 2: tmpSum = tmpSum + arr(N, 1): Next
      tmpSum = tmpSum + arr(25, 1) + arr(27, 1)
      iTmp(I) = IIf(arr(I, 1) <= tmpSum, "", I)
      tmpSum = 0
    Case Is = 9, 11, 13, 15, 17, 19, 21, 23, 26, 59, 62
      iTmp(I) = IIf(arr(I, 1) <= arr(I + 1, 1), "", I)
    Case Is = 28, 31
      iTmp(I) = IIf(arr(I, 1) > arr(I + 1, 1), "", I)
    Case Is = 29, 32, 47
      iTmp(I) = IIf(arr(I, 1) > arr(I + 1, 1), "", I)
    Case Is = 34, 37
      iTmp(I) = IIf(arr(I, 1) >= arr(I + 1, 1) Or arr(I, 1) >= arr(I + 2, 1), "", I)
    Case Is = 42, 49, 56
      iTmp(I) = IIf(arr(I, 1) >= arr(I + 1, 1) + arr(I + 2, 1), "", I)
    Case Is = 52, 60
      iTmp(I) = IIf(arr(I, 1) >= arr(I + 1, 1) + arr(I + 2, 1) + arr(I + 3, 1), "", I)
    Case Is = 64
      iTmp(I) = IIf(arr(I, 1) >= arr(I + 1, 1) Or arr(I, 1) >= arr(I + 2, 1) Or arr(I, 1) >= arr(I + 3, 1), "", I)
    Case Else
      iTmp(I) = ""
  End Select
Next
For I = 1 To UBound(iTmp)
  If iTmp(I) <> "" Then
    tmpStr = IIf(tmpStr = "", iTmp(I) & " - '" & Application.WorksheetFunction.VLookup(iTmp(I), condRng, 2, 0) & "'", _
                  tmpStr & vbCrLf & iTmp(I) & " - '" & Application.WorksheetFunction.VLookup(iTmp(I), condRng, 2, 0) & "'")
  End If
Next
PS_3_СВОД = IIf(tmpStr = "", "Все логические условия выполнены", "Не выполнены логические условия в строка:" & vbCrLf & tmpStr)
End Function

Sub DelRows()
Dim iSh As Worksheet
Dim lRow&, TestRow&
On Error Resume Next
For Each iSh In ThisWorkbook.Worksheets
  With iSh.UsedRange
    TestRow = .Find(what:="Тест", LookIn:=xlValues, LookAt:=xlWhole).Row
    lRow = .Row + .Rows.Count - 1
  End With
  If TestRow <> 0 And lRow > TestRow Then
    For I = lRow To TestRow + 1 Step -1
      iSh.Rows(I).Delete
    Next
  End If
  TestRow = 0: lRow = 0
Next
End Sub

Function PS_3(iRng As Range)
Dim arr()
Dim iTmp()
Dim I&, N&
Dim tmpSum%
arr = iRng.Value
ReDim iTmp(1 To UBound(arr, 1), 1 To 1)
For I = LBound(arr, 1) To UBound(arr, 1)
  Select Case I
    Case Is = 1
      For N = 2 To 5: tmpSum = tmpSum + arr(N, 1): Next
      iTmp(I, 1) = IIf(arr(I, 1) = tmpSum, True, False)
      tmpSum = 0
    Case Is = 6
      iTmp(I, 1) = IIf(arr(I, 1) = 0, True, False)
    Case Is = 7
      For N = 8 To 24 Step 2: tmpSum = tmpSum + arr(N, 1): Next
      tmpSum = tmpSum + arr(25, 1) + arr(27, 1)
      iTmp(I, 1) = IIf(arr(I, 1) <= tmpSum, True, False)
      tmpSum = 0
    Case Is = 9, 11, 13, 15, 17, 19, 21, 23, 26, 59, 62
      iTmp(I, 1) = IIf(arr(I, 1) <= arr(I + 1, 1), True, False)
    Case Is = 28, 31
      iTmp(I, 1) = IIf(arr(I, 1) > arr(I + 1, 1), True, False)
    Case Is = 29, 32, 47
      iTmp(I, 1) = IIf(arr(I, 1) > arr(I + 1, 1), True, False)
    Case Is = 34, 37
      iTmp(I, 1) = IIf(arr(I, 1) >= arr(I + 1, 1) Or arr(I, 1) >= arr(I + 2, 1), True, False)
    Case Is = 42, 49, 56
      iTmp(I, 1) = IIf(arr(I, 1) >= arr(I + 1, 1) + arr(I + 2, 1), True, False)
    Case Is = 52, 60
      iTmp(I, 1) = IIf(arr(I, 1) >= arr(I + 1, 1) + arr(I + 2, 1) + arr(I + 3, 1), True, False)
    Case Is = 64
      iTmp(I, 1) = IIf(arr(I, 1) >= arr(I + 1, 1) Or arr(I, 1) >= arr(I + 2, 1) Or arr(I, 1) >= arr(I + 3, 1), True, False)
    Case Else
      iTmp(I, 1) = ""
  End Select
Next
PS_3 = iTmp
End Function

Function RangetoHTML(rng As Range)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
    ' Copy the range and create a workbook to receive the data.
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
 
    ' Publish the sheet to an .htm file.
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
 
    ' Read all data from the .htm file into the RangetoHTML subroutine.
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
    ' Close TempWB.
    TempWB.Close savechanges:=False
 
    ' Delete the htm file.
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function