Dim FoundFIO As Range
Dim Diapazon As Range
Dim iLastRow As Long

Set FoundFIO = Columns(2).Find("Фамилия", , xlValues, xlWhole)
      iLastRow = FoundFIO.Offset(1).End(xlDown).Row
     set  Diapazon = Range(Cells(FoundFIO.Row + 1, "A"), Cells(iLastRow, "DB"))

Dim iLastColumn As Integer   

  Set FoundFIO = Columns(2).Find("Фамилия", , xlValues, xlWhole)
      iLastRow = FoundFIO.Offset(1).End(xlDown).Row
      iLastColumn = Cells(FoundFIO.Row, Columns.Count).End(xlToLeft).Column
      Set Diapazon = Range(Cells(FoundFIO.Row + 1, "A"), Cells(iLastRow, iLastColumn))

Option Explicit
Sub CheckingLog()
Dim arrFind()
Dim sFolder$, sFiles$, sumH&, I&, iFilename$, iStr$
Dim iWb  As Workbook
Dim cl As Range
Dim FreeCells As Integer
Dim sumFreeCells As Integer
Dim FoundFIO As Range
Dim Diapazon As Range
Dim iLastRow As Long
Dim iLastColumn As Integer
On Error Resume Next

arrFind = Array("Учитель:", "Предмет:", "Класс:", "Период:", "Учебный год:")
With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = False Then Exit Sub
    sFolder = .SelectedItems(1)
End With
sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
Application.ScreenUpdating = False
sFiles = Dir(sFolder & "*.xls*")
Do While sFiles <> ""
    Set iWb = Workbooks.Open(sFolder & sFiles)
    sumH = 0: sumFreeCells = 0: iFilename = Empty
          
          Set Diapazon = Range(Cells(FoundFIO.Row + 1, "A"), Cells(iLastRow, iLastColumn))
          
          Set FoundFIO = Columns(2).Find("Фамилия", , xlValues, xlWhole)
      iLastRow = FoundFIO.Offset(1).End(xlDown).Row
      iLastColumn = Cells(FoundFIO.Row, Columns.Count).End(xlToLeft).Column
      Diapazon = Range(Cells(FoundFIO.Row + 1, "A"), Cells(iLastRow, iLastColumn))
          
          
    'For Each cl In iWb.Worksheets(1).Diapazon.SpecialCells(2).Cells
        For Each cl In Diapazon.SpecialCells(2).Cells
            If cl.Value Like "2 Н" Or cl.Value Like "3 Н" Or cl.Value Like "4 Н" Or cl.Value Like "5 Н" Then
            sumH = sumH + 1
            cl.Interior.ColorIndex = 3
            cl.AddComment
            cl.Comment.Text Text:="" & vbCrLf & "оценка+Н"
        End If
            
       'Здесь проверка на 2+ 3 свободных ячейки
        If cl.Value Like "2" Then
        If IsEmpty(cl.Offset(, 1)) And IsEmpty(cl.Offset(, 2)) And IsEmpty(cl.Offset(, 3)) Then
           
            sumFreeCells = sumFreeCells + 1
            cl.Interior.ColorIndex = 3
            cl.AddComment
            cl.Comment.Text Text:="" & vbCrLf & "После двойки прошло более трех уроков без оценки"
        End If
        End If
      'Здесь проверка на 2+ 3 свободных ячейки
      
      
            
    Next
    
    With ThisWorkbook.Worksheets("отчет")
        .Range("F" & .Cells(.Rows.Count, "F").End(xlUp).Row + 1) = sumH
        .Range("G" & .Cells(.Rows.Count, "G").End(xlUp).Row + 1) = sumFreeCells
        
        For I = 0 To UBound(arrFind)
            Set cl = iWb.Worksheets(1).UsedRange.Find(arrFind(I), , xlValues, xlPart)
            If Not cl Is Nothing Then
iStr = Trim(Mid(cl.Value, WorksheetFunction.Search(":", cl.Value) + 1))
                .Cells(.Cells(.Rows.Count, I + 1).End(xlUp).Row + 1, I + 1) = iStr
                If I <= 2 Then
                    If iFilename <> Empty Then
                    iFilename = iFilename & " " & iStr
                    Else
                    iFilename = iStr
            End If
        End If
      End If
        Next
End With
iWb.SaveAs Filename:="" & iFilename & ".xlsx", FileFormat:=xlOpenXMLWorkbook
iWb.Close False
sFiles = Dir
Loop
Application.ScreenUpdating = True
End Sub

            Set cl = iWb.Worksheets(1).UsedRange.Find(arrFind(I), , xlValues, xlPart)

arrFind = Array("Учитель:", "Предмет:", "Класс:", "Период:", "Учебный год:")

 For I = 0 To UBound(arrFind)
            Set cl = iWb.Worksheets(1).UsedRange.Find(arrFind(I), , xlValues, xlPart)
            If Not cl Is Nothing Then