Sub Proverit()

    Dim myArrAvt(0 To 50) As Variant, sMerge As Variant
    Dim i As Integer, ii As Integer, n As Integer, PosStr As Integer
    Dim LDBname1 As String
    Dim Element As String
    n = 24

    Element = Worksheets("EXCEL").Cells(n, 11)
    PosStr = Cells(24, 1).End(xlDown).Row
    For n = 24 To PosStr
    
If Worksheets("EXCEL").Cells(n, 11) <> "4" Then
   LDBname1 = Worksheets("EXCEL").Cells(n, 2)
    ii = ii + 1: i = ii
      myArrAvt(ii) = Worksheets("EXCEL").Cells(n, 11)
    If ii < 50 Then
        If ii = 1 Then
         sMerge = myArrAvt(ii)
            Else
    For i = 1 To i
    If Element <> myArrAvt(ii) Then sMerge = sMerge & ", " & myArrAvt(i)
    Next i
        End If
        
    End If
End If
    Next n
End Sub

'---------------------------------------------------------------------------------------
' Module    : Module3
' Author    : diam
' Date      : 26.06.2020
' Purpose   :
'---------------------------------------------------------------------------------------
Const mdlName As String = "Module3"

Public Sub SaveFile()

   'Объявление переменных
   Dim CellValue As String
   Dim Path As String
   Dim FinalFileName As String

   'Временно отключаем показ вспомогательных сообщений
  Const prcName As String = "SaveFile"
  On Error GoTo ErrHandler
  
   Application.DisplayAlerts = False

   'Задаём каталог сохранения файла (в данном случае текущий каталог)
   
    Path = Worksheets("Листы").Cells(19, 8)
   
   'Проверка значения ячеек B14 и D14
   If Worksheets("EXCEL").Cells(8, 10) = "" Or Worksheets("EXCEL").Cells(9, 10).Value = "" Then
     MsgBox "В ячейке отсутствует значение", vbCritical, "Ошибка!"
     Exit Sub
   End If
   
   'Получаем значение ячейки
   'CellValue = Worksheets("EXCEL").Cells(8, 10).Value & " " & Worksheets("EXCEL").Cells(9, 10).Value
    CellValue = "TO" & Worksheets("EXCEL").Cells(14, 10).Value
   'Формируем итоговый путь и название файла
   FinalFileName = Path & CellValue & ".xlsx"

   'Сохраняем файл
      ActiveWorkbook.SaveAs Filename:=FinalFileName, _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
   
   '
                      'FileFormat:=xlOpenXMLWorkbookMacroEnabled 'Для сохранения файла с макросом
   'Включаем вывод сообщений
   Application.DisplayAlerts = True

   'Сообщение с результатом выполнения процедуры
   MsgBox "Файл успешно сохранен с названием - " & CellValue, vbInformation, "Результат"

Success:

mEx:
  Exit Sub

ErrHandler:
  Application.DisplayAlerts = True
  ErrorSave mdlName, prcName, Err.Number, "(" & Err.Description & ")" & vbCrLf & "в процедуре " & prcName & " of Module " & mdlName & " в строке " & Erl
  Resume mEx
  Resume

  End Sub

If zamechanijaPR = 0 Then
Sheets("Осмотр").Cells(5, 15) = "Соответствует"
Else
Sheets("Осмотр").Cells(5, 15) = "Не соответствует"
End If

Worksheets("EXCEL").Cells(n, 6).Replace "р", "x", xlPart

Sub SaveFile()

   'Объявление переменных
   Dim CellValue As String
   Dim Path As String
   Dim FinalFileName As String

   'Временно отключаем показ вспомогательных сообщений
   Application.DisplayAlerts = False

   'Задаём каталог сохранения файла (в данном случае текущий каталог)
   'Path = ThisWorkbook.Path & "\"
    Path = "C:\Users\Roza\Desktop\ТО" & "\"
   
   'Проверка значения ячеек B14 и D14
   If Worksheets("EXCEL").Cells(8, 10) = "" Or Worksheets("EXCEL").Cells(9, 10).Value = "" Then
     MsgBox "В ячейке отсутствует значение", vbCritical, "Ошибка!"
     Exit Sub
   End If
   
   'Получаем значение ячейки
   CellValue = Worksheets("EXCEL").Cells(8, 10).Value & " " & Worksheets("EXCEL").Cells(9, 10).Value

   'Формируем итоговый путь и название файла
   FinalFileName = Path & CellValue

   'Сохраняем файл
   ActiveWorkbook.SaveAs Filename:=FinalFileName, _
                      FileFormat:=xlOpenXMLWorkbook
                      'FileFormat:=xlOpenXMLWorkbookMacroEnabled 'Для сохранения файла с макросом
   'Включаем вывод сообщений
   Application.DisplayAlerts = True

   'Сообщение с результатом выполнения процедуры
   MsgBox "Файл успешно сохранен с названием - " & CellValue, vbInformation, "Результат"

  End Sub

kon1 = Int((4 * Rnd) + 1) / 100: Cells(13, 3).NumberFormat = "0.00"
Cells(13, 3) = kon1

Доброго времени суток, подскажите как организовать подсчет определенных строк. Условия следующие: пока в столбце "В" имя ШР 5.1.8 подсчитать коль-во строк имеющих в столбце "С" ввод и группа. После изменения имени в "В" нужно обнулить счетчики и начать подсчет строк с теми же условиями, но уже с другим именем и т.д. Файл для наглядности приложил.
Пробовал сделать следующим образом:

Dim kolVk As Integer, kolgr As Integer

kolVk = 0
kolgr = 0

'kolVk- счетчик для ввода
'kolgr-счетчик для группа
LDB = ""
Do While LDB = LDB
If Worksheets("EXCEL").Cells(nrs, 3) = "ввод" Then kolVk = kolVk + 1
If Worksheets("EXCEL").Cells(nrs, 3) = "группа" Then kolgr = kolgr + 1
nrs = nrs + 1
Loop

Cells(28 + npp, 3) = "Количество вводов "
Cells(28 + npp, 4) = kolVk
Cells(28 + npp + 1, 3) = "Количество групп "
Cells(28 + npp + 1, 4) = kolgr
Cells(28 + npp, 5) = "< 0,5"
Cells(28 + npp, 6) = Int((25 - 15 + 1) * Rnd + 15) / 100: Cells(28 + npp, 18).NumberFormat = "0.00"

WrdName = "D:\Íîâàÿ ïàïêà\Ïðîòîêîë 5.doc"
  'WrdName = InputBox("Укажите путь к шаблону:", NameApp, WrdName)
  If WrdName = "" Then
    MsgBox "Не задан путь к файлу", vbExclamation, NameApp
    GoTo mEx
  End If
'  If Not WrdName Like "*\*" Then WrdName = ActiveWorkbook.Path & "\" & WrdName
  On Error Resume Next
  Set objWrdApp = GetObject(, "Word.Application")
  If objWrdApp Is Nothing Then
    Set objWrdApp = CreateObject("Word.Application")
    objWrdApp.Visible = True
  End If
  On Error GoTo ErrHandler

  Set objWrdDoc = objWrdApp.Documents.Open(WrdName)  '("D:\Dev\ÒÎ 5085 — êîïèÿ.doc")
  'objWrdApp.ScreenUpdating = False
  'objWrdApp.Visible = True
    'End If
      
     '1 найдем открытые документы Ворда
     '2 Предложим какой ворд использовать
     '3 Найдем нужную таблицу с коль-ом столбцов 15
  
  For TableIndex = 1 To objWrdDoc.Tables.Count
    Set objWrdTab = objWrdDoc.Tables(TableIndex)
    'Таблица должна быть из 3 строк и  15столбцов
    If objWrdTab.Rows.Count = 3 And objWrdTab.Columns.Count = 15 Then
      If Left(objWrdTab.Cell(2, 13).Range.Text, 16) = "Допустимое" Then
        IsTabFound = True
        Exit For
      End If
    End If
  Next
  If IsTabFound = False Then
    MsgBox "таблиц аНе найдена ", vbExclamation, NameApp

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B28:B5000]) Is Nothing Then Exit Sub
If [B28:B5000].Text = "" Then Exit Sub
Dim r As Range, i&
Application.EnableEvents = False
'If Target <> "" Then Target = ""
For Each r In [B28:B5000].SpecialCells(2)
        i = i + 1: r = i
Next r
Application.EnableEvents = True
End Sub