Sub MakeDiagramm()
  Const D0 = 300
  Dim shp, a, c&, i&, m, D, rg As Range
  Set rg = Range(Cells(2, 2), Cells(2, 2).End(xlDown))
  a = rg: c = UBound(a)
  For i = 1 To c: If a(i, 1) > m Then m = a(i, 1)
  Next
  For i = 1 To c
    D = a(i, 1) * D0 / m
    Set shp = ActiveSheet.Shapes.AddShape(msoShapePie, D0 - D / 2, D0 - D / 2, D, D)
    shp.Adjustments.Item(1) = 270 - 360 / c
    rg(i).Interior.ColorIndex = i + 2
    shp.Fill.ForeColor.RGB = rg(i).Interior.Color
    shp.IncrementRotation 360 * (i - 1) / c
  Next
  ActiveSheet.Shapes.SelectAll
  Selection.Group
End Sub

Cells(1).Resize(UBound(a), UBound(a, 2)) = a

Cells(1).Resize(UBound(a), 1) = a

Sub FillAA()
  Const dc& = 17
  Dim a, c&, c0&, c1&, d, r&
  Set d = CreateObject("Scripting.Dictionary")
  c = RGB(200, 200, 200): c0 = xlNone
  a = Range(Cells(1, 2), Cells(Rows.Count, 1).End(xlUp))
  For r = 2 To UBound(a)
    If d.exists(a(r, 1)) Then
      c1 = d(a(r, 1))
      If c1 < 0 Then
        c = c + dc: d(a(r, 1)) = c: a(-c1, 2) = c: a(r, 2) = c
      Else
        a(r, 2) = c1
      End If
    Else
      d(a(r, 1)) = -r: a(r, 2) = c0
    End If
  Next
  Cells(1).Resize(UBound(a), UBound(a, 2)) = a
  For r = 2 To UBound(a)
    Cells(r, 1).Interior.Color = a(r, 2)
  Next
End Sub

=МАКС(0;СУММ($F$7:F$7)-СУММЕСЛИ($C$5:E$5;"<" & ДАТАМЕС(F$5;-ОСТАТ(МЕСЯЦ(F$5)-1;3));$C$9:E$9)-ЕСЛИ(СТОЛБЕЦ()=6;;СУММ(E$15:$F$15)))

=F7-ЕСЛИ(ОСТАТ(МЕСЯЦ(F5)-1;3);;СУММЕСЛИ($C$5:E5;">=" & ДАТАМЕС(F5;-3);$C$9:E9))

;2))))

;2));))

Sub DelSCHT()
  Dim rg As Range
  Do
    Set rg = Cells.Find("шт", , xlValues, xlWhole, SearchFormat:=False)
    If rg Is Nothing Then Exit Do
    If IsNumeric(rg.Offset(-1)) Then
      Rows(rg.Row - 1).Resize(2).Delete
    Else
      Rows(rg.Row).Delete
    End If
  Loop
End Sub

  Application.ScreenUpdating = False
  Worksheets.Add
  ActiveSheet.Visible = xlSheetHidden
  Application.ScreenUpdating = True

Function GetMask(s$, m$)
  Dim re
  Set re = CreateObject("VBScript.RegExp")
  re.Pattern = m
  If re.test(s) Then GetMask = re.Execute(s)(0).submatches(0)
End Function

On Error GoTo На_выход

На_выход:
End Sub

Function I9_600(kc&)
  Dim c&, rg As Range, rg1 As Range
  Set rg = Cells(9, 9).Resize(592, 1): Set rg1 = rg
  For c = 2 To (kc - 1) * 2 Step 2
    Set rg = Union(rg, rg1.Offset(0, c))
  Next
  Set I9_600 = rg
End Function

Sub Banzay()
  Dim c&
  'используйте функцию I9_600 везде где нужно обратиться к I9...600
  c = [i3]: If c = 0 Then c = 5
  I9_600(c).Select
  MsgBox "Range " & I9_600(c).Address(0, 0) & " selected"
End Sub

Sub Banzay()
  Dim a, r&, re
  Set re = CreateObject("VBScript.RegExp"): re.Pattern = "\d{12}"
  a = Range(Cells(1, 4), Cells(Rows.Count, 4).End(xlUp))
  For r = 1 To UBound(a)
    If a(r, 1) = "БЫЛО" Then a(r, 1) = "СТАЛО"
    If re.test(a(r, 1)) Then a(r, 1) = re.Execute(a(r, 1))(0)
  Next
  Cells(1, 4).Resize(UBound(a), 1) = a
End Sub