Const cnstNom = 2
Const cnstName = 3
Const cnstGod = 5
Const cnstNomer = 2
Const cnstNames = 3
Const cnstGodd = 4
Const cnstBal = 5
Const cnstSum = 4
Const cnstBalls = 10

Function GetCritValue(ByRef Cells() As Variant, CurRow As Integer, n As Variant) As Double
If n = 0 Then
GetCritValue = 0
Else
If Cells(CurRow, cnstGod) > 0 Then
GetCritValue = Cells(CurRow, cnstSum) / Cells(CurRow, cnstGod) / n
Else
GetCritValue = 0
End If
End If
End Function
Sub Test()
Dim Book As Excel.Workbook
Dim Sheet As Excel.Worksheet
Dim sFolder As String
Dim sFiles As String
Dim a() As Variant
Dim i As Integer
Dim ii As Integer
Dim x As Integer
Dim ILastrow As Integer
Dim oDict As Object
Dim calc_status&
sFolder = ThisWorkbook.Path & "\5\"
sFiles = Dir(sFolder & "*.xls")
Set oDict = CreateObject("Scripting.Dictionary")
oDict.CompareMode = 1
With Application
calc_status = .Calculation
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
a = .Sheets(1).UsedRange.Value
For i = 5 To UBound(a)
If Len(a(i, cnstNom)) Then
If oDict.exists(a(i, cnstNom)) Then
oDict.Item(a(i, cnstNom)) = 1
End If
Else
Exit For
End If
Next
Do While sFiles <> ""
With GetObject(sFolder & sFiles)
a = .Sheets(1).UsedRange.Value
ReDim b(1 To UBound(a), 1 To 4)
ii = 0
n = Val(InputBox("Введите число N"))
k = Val(InputBox("Введите число которое подходит по условию"))
For i = 5 To UBound(a)
If Len(a(i, cnstNom)) Then
             If Not oDict.exists(a(i, cnstNom)) Then    'если нет в словаре
                  If GetCritValue(a, i, n) > k Then    'если прошёл сейчас проверку
                      oDict.Item(a(i, cnstNom)) = 1    ' ставим 1
                  Else
                      oDict.Item(a(i, cnstNom)) = 0    ' иначе 0
                  End If
              Else    'если есть уже в словаре
                  If oDict.Item(a(i, cnstNom)) = 1 Then    'если все предыдущие проверки прошёл
                      If Not GetCritValue(a, i, n) > k Then ' проверяем снова, если не прошёл
                          oDict.Item(a(i, cnstNom)) = 0 ' ставим 0
                            End If
               End If
                  
              If oDict.Item(a(i, cnstNom)) = 1 Then ' если есть в словаре, то переносим остальные значения
ii = ii + 1
b(ii, 1) = a(i, cnstNom)
b(ii, 2) = a(i, cnstName)
b(ii, 3) = a(i, cnstGod)
b(ii, 4) = cnstBalls
    End If
      End If
       End If
Next
sFiles = Dir
.Close 0
End With
If ii > 0 Then
ILastrow = Cells(Rows.Count, 5).End(xlUp).Row
Cells(ILastrow + 1, cnstNom).Resize(ii, 4) = b
End If
Loop
.Calculation = calc_status
.ScreenUpdating = True
.EnableEvents = True
    n = 1
      For RowNo = 4 To Range("B4").SpecialCells(xlLastCell).Row - 1
       Лист1.Cells(RowNo + 1, 1) = n
        n = n + 1
      Next RowNo
End With
End Sub

Const cnstNom = 2
Const cnstName = 3
Const cnstGod = 5
Const cnstNomer = 2
Const cnstNames = 3
Const cnstGodd = 4
Const cnstBal = 5
Const cnstSum = 4
Const cnstBalls = 10

Function GetCritValue(ByRef Cells() As Variant, CurRow As Long, n As Variant) As Double
     If n = 0 Then
         GetCritValue = 0
     Else
         If Cells(CurRow, cnstGod) > 0 Then
             GetCritValue = Cells(CurRow, cnstSum) / Cells(CurRow, cnstGod) / n
         Else
             GetCritValue = 0
         End If
     End If
End Function

Sub Test()
     Dim Book As Excel.Workbook
     Dim Sheet As Excel.Worksheet
     Dim sFolder As String
     Dim sFiles As String
     Dim a() As Variant
     Dim i As Long
     Dim ii As Long
     Dim x As Long
     Dim p As Long
     Dim ILastrow As Long
     Dim oDict As Object
     Dim calc_status&
     sFolder = ThisWorkbook.Path & "\5\"
     sFiles = Dir(sFolder & "*.xls")
     Set oDict = CreateObject("Scripting.Dictionary")
     oDict.CompareMode = 1
     With Application
         calc_status = .Calculation
         .Calculation = xlManual
         .ScreenUpdating = False
         .EnableEvents = False
         a = .Sheets(1).UsedRange.Value

         For i = 5 To UBound(a)
             If Len(a(i, cnstNom)) Then
                 If Not oDict.exists(a(i, cnstNom)) Then
                     oDict.Item(a(i, cnstNom)) = 0
                     p = i - 4    'считаем присутствующих
                 End If
             Else
                 Exit For
             End If
         Next

         ReDim b(1 To 1000, 1 To 4)

         Do While sFiles <> ""
             With GetObject(sFolder & sFiles)
                 a = .Sheets(1).UsedRange.Value
                 n = Val(InputBox("Открыт " & sFiles & " Введите число N"))
                 k = Val(InputBox("Введите число которое подходит по условию для " & sFiles))
                 For i = 5 To UBound(a)
                     If Len(a(i, cnstNom)) Then
                         If Not oDict.exists(a(i, cnstNom)) Then    'если нет в словаре
                             If GetCritValue(a, i, n) > k Then    'если прошёл сейчас проверку
                    p = p + 1
                    oDict.Item(a(i, cnstNom)) = p    ' ставим p
                    'заполняем массив данными
                    b(p, 1) = a(i, cnstNom)
                    b(p, 2) = a(i, cnstName)
                    b(p, 3) = a(i, cnstGod)
                    b(p, 4) = cnstBalls
                             Else
                    oDict.Item(a(i, cnstNom)) = 0    ' иначе 0
                             End If
                         Else    'если есть уже в словаре
                             If oDict.Item(a(i, cnstNom)) <> 0 Then    'если все предыдущие проверки прошёл
                    If Not GetCritValue(a, i, n) > k Then    ' проверяем снова, если не прошёл
                    b(oDict.Item(a(i, cnstNom)), 1) = ""
                    oDict.Item(a(i, cnstNom)) = 0    ' ставим 0
                    End If
                             End If
                         End If
                     End If
                 Next
                 sFiles = Dir
                 .Close 0
             End With
         Loop

         ReDim c(1 To 1000, 1 To 4)
         For i = 1 To 1000
             If Len(b(i, 1)) Then
                 ii = ii + 1
                 For x = 1 To 4: c(ii, x) = b(i, x): Next
             End If
         Next

         If ii > 0 Then
             ILastrow = Cells(Rows.Count, 5).End(xlUp).Row
             Cells(ILastrow + 1, cnstNom).Resize(ii, 4) = c
         End If

         .Calculation = calc_status
         .ScreenUpdating = True
         .EnableEvents = True
         n = 1
         For RowNo = 4 To Range("B4").SpecialCells(xlLastCell).Row - 1
             Лист1.Cells(RowNo + 1, 1) = n
             n = n + 1
         Next RowNo
     End With
End Sub

Const cnstNom = 2
Const cnstName = 3
Const cnstGod = 5
Const cnstNomer = 2
Const cnstNames = 3
Const cnstGodd = 4
Const cnstBal = 5
Const cnstSum = 4
Const cnstBalls = 10

Function GetCritValue(ByRef Cells() As Variant, CurRow As Long, n As Variant) As Double
      If n = 0 Then
          GetCritValue = 0
      Else
          If Cells(CurRow, cnstGod) > 0 Then
              GetCritValue = Cells(CurRow, cnstSum) / Cells(CurRow, cnstGod) / n
          Else
              GetCritValue = 0
          End If
      End If
End Function

Sub Test()
      Dim Book As Excel.Workbook
      Dim Sheet As Excel.Worksheet
      Dim sFolder As String
      Dim sFiles As String
      Dim a() As Variant
      Dim i As Long
      Dim ii As Long
      Dim x As Long
      Dim el
      Dim ILastrow As Long
      Dim oDict As Object
      Dim calc_status&
      Dim ForItArr(1 To 4)
      Dim ItArr()

      sFolder = ThisWorkbook.Path & "\5\"
      sFiles = Dir(sFolder & "*.xls")
      Set oDict = CreateObject("Scripting.Dictionary")
      oDict.CompareMode = 1
      With Application
          calc_status = .Calculation
          .Calculation = xlManual
          .ScreenUpdating = False
          .EnableEvents = False

          a = .Sheets(1).UsedRange.Value

          For i = 5 To UBound(a)
              If Len(a(i, cnstNom)) Then
                  If Not oDict.exists(a(i, cnstNom)) Then
                      oDict.Item(a(i, cnstNom)) = 0
                  End If
              Else
                  Exit For    'если данных ниже нет(UsedRange ещё может продолжаться)
              End If
          Next

          Do While sFiles <> ""
              With GetObject(sFolder & sFiles)
                  a = .Sheets(1).UsedRange.Value
                  n = Val(InputBox("Открыт " & sFiles & " Введите число N"))
                  k = Val(InputBox("Введите число которое подходит по условию для " & sFiles))
                  For i = 5 To UBound(a)
                      If Len(a(i, cnstNom)) Then
                          If Not oDict.exists(a(i, cnstNom)) Then    'если нет в словаре
                    If GetCritValue(a, i, n) > k Then    'если прошёл сейчас проверку
                    'делаем чистый массив
                     ItArr = ForItArr
                     'заполняем массив данными
                     ItArr(1) = a(i, cnstNom)
                     ItArr(2) = a(i, cnstName)
                     ItArr(3) = a(i, cnstGod)
                     ItArr(4) = cnstBalls
                     'помещаем массив в словарь
                     oDict.Item(a(i, cnstNom)) = ItArr

                    Else
                     oDict.Item(a(i, cnstNom)) = 0    ' иначе 0
                    End If
                          Else    'если есть уже в словаре
                    If IsArray(oDict.Item(a(i, cnstNom))) Then     'если все предыдущие проверки прошёл
                     If Not GetCritValue(a, i, n) > k Then    ' проверяем снова, если не прошёл
                     oDict.Item(a(i, cnstNom)) = 0    ' ставим 0
                     End If
                    End If
                          End If
                      End If
                  Next
                  sFiles = Dir
                  .Close 0
              End With
          Loop
          ReDim b(1 To oDict.Count, 1 To 4)
          For Each el In oDict.keys
              If IsArray(oDict.Item(el)) Then
                  ii = ii + 1
                  For x = 1 To 4: b(ii, x) = oDict.Item(el)(x): Next
              End If
          Next
          If ii > 0 Then 'если есть что выгружать
              ILastrow = Cells(Rows.Count, 5).End(xlUp).Row
              Cells(ILastrow + 1, cnstNom).Resize(ii, 4) = b
          End If
          .Calculation = calc_status
          .ScreenUpdating = True
          .EnableEvents = True
          n = 1
          For RowNo = 4 To Range("B4").SpecialCells(xlLastCell).Row - 1
              Лист1.Cells(RowNo + 1, 1) = n
              n = n + 1
          Next RowNo
      End With
End Sub