Function GetSum(s, p)
  Dim f(1 To 1, 1 To 2), m, re
  Set re = CreateObject("VBScript.RegExp"): re.Pattern = p
  f(1, 2) = "": GetSum = f
  If Not re.test(s) Then Exit Function
  re.Pattern = p & " \(([0-9 ]+)\) ([A-Z]+)"
  If Not re.test(s) Then Exit Function
  Set m = re.Execute(s)(0)
  f(1, 1) = Replace(m.submatches(0), " ", ""):
  f(1, 2) = m.submatches(1): GetSum = f
End Function

Sub Join3Arr()
  Dim a, b, c, d, e&, k&, r&
  a = [d10].CurrentRegion: b = [j10].CurrentRegion: c = [l10].CurrentRegion
  ReDim d(2 To UBound(a), 1 To UBound(a, 2) + UBound(b, 2) + UBound(c, 2))
  For r = 2 To UBound(a)
    k = 0
    For e = 1 To UBound(a, 2): d(r, k + e) = a(r, e): Next
    k = k + UBound(a, 2)
    For e = 1 To UBound(b, 2): d(r, k + e) = b(r, e): Next
    k = k + UBound(b, 2)
    For e = 1 To UBound(c, 2): d(r, k + e) = c(r, e): Next
  Next
  [o11].Resize(UBound(d) - 1, UBound(d, 2)) = d
End Sub

=СЧЁТЕСЛИ($B$2:$B$13;A1)

Sub SortTbl()
  Dim a, b, i&, r&, r1&, rg As Range
  Set rg = [a1].CurrentRegion:  SortRangeBy rg, Array(2, 3): a = rg
  rg.Copy: Cells(1, 5).PasteSpecial xlPasteValues
  Intersect(Range("E:G"), ActiveSheet.UsedRange).RemoveDuplicates 2, xlYes
  Set rg = [e1].CurrentRegion: SortRangeBy rg, Array(3)
  Range([e2], Cells(Rows.Count, 6).End(xlUp).Offset(0, -1)) = "=Row()"
  rg = rg.Value: SortRangeBy rg, Array(2): b = rg: r1 = 2
  For r = 2 To UBound(b)
    i = 0
    Do While a(r1 + i, 2) = a(r1, 2)
      i = i + 1: If i + r1 = UBound(a) Then Exit Do
    Loop
    Cells(r1, 1).Resize(i, 1) = b(r, 1): r1 = r1 + i
  Next
  SortRangeBy [a1].CurrentRegion, Array(1, 3)
  Cells(2, 1).Resize(UBound(a) - 1, 1) = Empty: [e:g].ClearContents
End Sub


Sub SortRangeBy(rg As Range, c, Optional Hd& = 1)
  Dim i&
  With rg.Parent.Sort
    .SortFields.Clear
    For i = LBound(c) To UBound(c)
      .SortFields.Add Key:=rg.Cells(1).Offset(Hd, Abs(c(i)) - 1).Resize( _
      rg.Rows.Count - Hd, 1), SortOn:=xlSortOnValues, Order:=IIf(c(i) > 0, _
      1, 2), DataOption:=xlSortNormal
    Next
    .SetRange rg: .Header = Hd: .MatchCase = False
    .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
  End With
End Sub

Sub EColumn()
  Dim e, r&
  e = Range([e1], Cells(Rows.Count, 5).End(xlUp))
  For r = 1 To UBound(e): e(r, 1) = WithOutDgt(e(r, 1)): Next
  [g1].Resize(UBound(e), 1) = e
End Sub

Function WithOutDgt$(s)
  Dim re: WithOutDgt = s
  Set re = CreateObject("VBScript.RegExp"): re.Pattern = "^\d+"
  If re.test(s) Then WithOutDgt = re.Replace(s, "")
End Function

  Dim r
  r = 1
  Do While Not IsEmpty(Cells(r, 1))
    r = r + 1
    If r > 10000 Or r > [aa1] Then Exit Do
  Loop