Sub SortAndSaveFamily()
  Dim a, b, c&, i&, j&, k&, N, rg As Range
  Set rg = Intersect([4:1048576], ActiveSheet.UsedRange)
  ReDim N(1 To rg.Rows.Count, 1 To 1)
  For i = 2 To UBound(N): N(i, 1) = i - 1: Next
  N(1, 1) = "№": Cells(4, 1).Resize(UBound(N), 1) = N
  c = ActiveSheet.UsedRange.Columns.Count + 3: a = rg
  Intersect(rg, [a:b,h:h]).Copy Cells(1, c)
  Cells(1, c).Resize(rg.Rows.Count, 3).RemoveDuplicates Columns:=3, Header:=xlYes
  If IsEmpty(Cells(3, c + 2)) Then Cells(3, c).Resize(1, 3).Delete
  ReDim N(1 To rg.Rows.Count, 1 To 1)
  Set rg = Cells(1, c).CurrentRegion: SortRangeBy rg, Array(2): b = rg
  Columns(c).Resize(, 3).Delete
  For i = 2 To UBound(b)
    j = b(i, 1) + 2: k = 1: N(b(i, 1) + k, 1) = i
    Do While IsEmpty(a(j, 6)) And (Not IsEmpty(a(j, 2)))
      k = k + 1: j = j + 1: N(b(i, 1) + k, 1) = i + k / 25
    Loop
  Next
  Cells(4, UBound(a, 2) + 1).Resize(UBound(N), 1) = N
  SortRangeBy Intersect([4:1048576], ActiveSheet.UsedRange), Array(UBound(a, 2) + 1)
  Columns(UBound(a, 2) + 1).Delete
  For i = 2 To UBound(N): N(i, 1) = i - 1: Next
  N(1, 1) = "№": Cells(4, 1).Resize(UBound(N), 1) = N
End Sub

Sub Delete_copy_in_A()
  Range([b1], Cells(Rows.Count, 1).End(xlUp)).RemoveDuplicates 1, xlNo
End Sub

Function Tail$(s$)
  Dim p&(1 To 2)
  p(1) = InStrRev(s, "_"): If p(1) = 0 Then Exit Function Else p(1) = p(1) + 1
  p(2) = InStrRev(s, "."): If p(2) = 0 Then Exit Function
  Tail = Mid(s, p(1), p(2) - p(1))
End Function

With ActiveSheet
  .UnProtect
  ' форматируем что хотим в свое удовольствие
  .Protect
End With

=G2-F2-2

Sub DeleteRows()
  Rows.Delete
End Sub

Sub OpenOneFile()
  Dim f$, pt$
  pt = ThisWorkbook.Path & "\Папка\Подпапка\"
  FName = Dir(pt & "\подфайл*.xlsx")
  If FName <> "" Then Workbooks.Open pt & FName
End Sub

Function DelBlancRow(s$)
  Do While Left(s, 1) = vbLf: s = Right(s, Len(s) - 1)
  Loop
  Do While InStr(s, vbLf & vbLf): s = replace(s, vbLf & vbLf, vbLf)
  Loop
  DelBlancRow = s
End Function

Sub DirSub()
  Dim f$
  f = Dir("c:\t*.*", vbDirectory)
  Do While f <> ""
    Debug.Print f: f = Dir
  Loop
End Sub

="Документы не предоставлены: " & ПОДСТАВИТЬ(ПОДСТАВИТЬ(ОБЪЕДИНИТЬ(",";1;Таблица5[Результат]);"Замечаний нет,";"");",Замечаний нет";"")