Sub enstaralfgg()
Dim Rg1 As Range, kRw$, kSh%, i&
Const Ima As String = "Раздел"
kRw = 50
Set Rg1 = ThisWorkbook.Worksheets(1).Cells(1).CurrentRegion

kRw = InputBox(vbNullString, "Введите количество строк на листе", kRw)
If StrPtr(kRw) = 0 Then Exit Sub
If kRw = vbNullString Then Exit Sub
kSh = Rg1.Rows.Count \ kRw + 1

If MsgBox("Создать " & kSh & " новых листов с данными" & _
vbNewLine & "Продолжить?", 52, "ВНИМАНИЕ!") = 7 Then Exit Sub
Set Rg1 = Rg1.Resize(kRw, Rg1.Columns.Count)

    Application.ScreenUpdating = False
For i = 1 To kSh
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = Ima & i
    Rg1.Copy Cells(1)
    Set Rg1 = Rg1.Offset(kRw, 0)
Next
    Application.ScreenUpdating = True
End Sub

Sub enstaralggt()
Cells(2) = CreateObject("OlePrn.OleCvt.1").ToUnicode(Cells(1), 65001)
End Sub

Debug.Print ObjPtr(dicCopy), ObjPtr(dic)

Sub enstaralg1()
Dim ArVh, Ar1, i&, j&, Tp1, Ar2() As Long
ArVh = Array("A", "B", "C", "D", "E")
Ar1 = Cells(1).CurrentRegion.Value
ReDim Ar2(UBound(Ar1) - 1, UBound(ArVh))
For i = 2 To UBound(Ar1)
    Tp1 = Split(Ar1(i, 1))
    For j = 0 To UBound(Tp1)
        Select Case Left(Tp1(j), 1)
            Case ArVh(0): Ar2(i - 2, 0) = Ar2(i - 2, 0) + --Mid(Tp1(j), 2)
            Case ArVh(1): Ar2(i - 2, 1) = Ar2(i - 2, 1) + --Mid(Tp1(j), 2)
            Case ArVh(2): Ar2(i - 2, 2) = Ar2(i - 2, 2) + --Mid(Tp1(j), 2)
            Case ArVh(3): Ar2(i - 2, 3) = Ar2(i - 2, 3) + --Mid(Tp1(j), 2)
            Case ArVh(4): Ar2(i - 2, 4) = Ar2(i - 2, 4) + --Mid(Tp1(j), 2)
        End Select
Next j, i
With Range("I1")
    .Resize(, UBound(Ar2, 2) + 1) = ArVh
    .Offset(1).Resize(UBound(Ar2), UBound(Ar2, 2) + 1) = Ar2
End With
End Sub

Sub enstaralg2()
Dim Dic, ArVh, Ar1, i&, j&, Tp1, Ar2() As Long
Set Dic = CreateObject("Scripting.Dictionary")
ArVh = Array("A", "B", "C", "D", "E")
Ar1 = Cells(1).CurrentRegion.Value
ReDim Ar2(UBound(Ar1) - 1, UBound(ArVh))
For i = 2 To UBound(Ar1)
    Tp1 = Split(Ar1(i, 1))
    For j = 0 To UBound(Tp1)
    Dic(Left(Tp1(j), 1)) = Dic(Left(Tp1(j), 1)) + --Mid(Tp1(j), 2)
    Next j
    For j = 0 To UBound(ArVh)
    If Dic.Exists(ArVh(j)) Then Ar2(i - 2, j) = Dic(ArVh(j))
    Next j
Dic.RemoveAll
Next i
With Range("I1")
    .Resize(, UBound(Ar2, 2) + 1) = ArVh
    .Offset(1).Resize(UBound(Ar2), UBound(Ar2, 2) + 1) = Ar2
End With
End Sub

Sub enstaralfgf()
Dim Ar1, Ar2, i&, j&, ii&, jj&
Const Raz = 8
Ar1 = Cells(1).CurrentRegion
ReDim Ar2(1 To UBound(Ar1, 2) * UBound(Ar1, 1) / Raz, 1 To Raz)
ii = 1: jj = Raz
For i = 1 To UBound(Ar1)
    For j = UBound(Ar1, 2) To 1 Step -1
    Ar2(ii, jj) = Ar1(i, j)
    jj = jj - 1
    If jj = 0 Then jj = Raz: ii = ii + 1
Next j, i
Range("H5").Resize(UBound(Ar2, 1), UBound(Ar2, 2)).Value = Ar2
End Sub

Application.OnTime NextStart, "ExampleUsage", , False

=ПСТР(A1;ПОИСК("/";A1)+1;99)

Cells(1) = Shell("C:\Program Files\Windows Media Player\wmplayer.exe C:\Users\1.mp3", vbHide)

Shell "TaskKill /F /PID " & CStr(Cells(1)), vbHide

Shell "C:\Program Files\Windows Media Player\wmplayer.exe C:\Users\1.mp3", 0

With CreateObject("WScript.Shell")
.Run "C:\Users\1.mp3", 0
End With

Function Max_Min_Data(DiapDat As Range, DiapSum As Range, Optional Max_Min% = 1) As Double
Dim Ar1, Ar2
Ar2 = DiapDat.Value: Ar1 = DiapSum.Value
For i = 1 To UBound(Ar1, 2)
If Ar1(1, i) <> "" Then Ar1(1, i) = VBA.CDbl(Ar2(1, i))
Next i
If Max_Min = 0 Then Max_Min_Data = WorksheetFunction.Min(Ar1) Else Max_Min_Data = WorksheetFunction.Max(Ar1)
End Function

=1/МАКС(1/$E$2:$N$2*ЕЧИСЛО(E3:N3))

=МАКС($E$2:$N$2*ЕЧИСЛО(E3:N3))

Function Оценки(диапазон As Range, критерий%) As Long
Dim arr, i&, j&
arr = диапазон.Value: Оценки = UBound(arr)
For i = 1 To UBound(arr): For j = 1 To UBound(arr, 2)
If arr(i, j) < критерий Or Not VBA.IsNumeric(arr(i, j)) Then Оценки = Оценки - 1: Exit For
Next j, i
End Function

Function MinNagr(Время_Наиб_Нагр$) As String
Dim Ar1, Ar2, ii&
    Ar1 = Split(Время_Наиб_Нагр, "-")
For ii = LBound(Ar1) To UBound(Ar1)
    Ar2 = Split(Trim(Ar1(ii)), ";")
    If UBound(Ar2) = 0 Then
    If Ar2(0) = "23:59:59" Then Exit For
        If MinNagr = "" Then
If Ar2(0) <> "00:00:00" Then MinNagr = "00:00:00" & "-" & Format(TimeValue(Ar2(0)) - 1 / 86400, "hh:mm:ss")
        Else
MinNagr = MinNagr & ";" & Format(TimeValue(Ar2(0)) + 1 / 86400, "hh:mm:ss") & "-" & "23:59:59"
        End If
    Else
MinNagr = MinNagr & ";" & Format(TimeValue(Ar2(0)) + 1 / 86400, "hh:mm:ss") & "-" & Format(TimeValue(Ar2(1)) - 1 / 86400, "hh:mm:ss")
    End If
Next
If MinNagr Like ";*" Then MinNagr = VBA.Mid(MinNagr, 2)
End Function

Sub aaaвв()
Range("P4").AutoFill Destination:=Range("P4").Resize(Range("A4").End(xlDown).Row - Range("P4").Row + 1) 'растянуть формулу
    Calculate 'пересчитать
With Range(Range("P5"), Range("P5").End(xlDown))
.Copy        'выделить вниз
.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
              :=False, Transpose:=False 'вставить только значения
End With
End Sub

=ЕСЛИ((ПСТР($A2;СТОЛБЕЦ(A2);1)= "+");1;0)

=Ч(ПСТР($A2;СТОЛБЕЦ(A2);1)="+")

Sub enstaralfdh()
Dim Arr, ArByt() As Byte
ReDim Arr(VBA.Len(ActiveCell) - 1)
ArByt = VBA.StrConv(ActiveCell, vbFromUnicode)
For i = 0 To UBound(ArByt)
If ArByt(i) = 45 Then ArByt(i) = 48
If ArByt(i) = 43 Then ArByt(i) = 49
Arr(i) = VBA.Chr(ArByt(i))
Next
ActiveCell(, 2).Resize(, UBound(ArByt) + 1) = Arr
End Sub