Sub enstaralfdh()
Dim Rg1 As Range, Rg2 As Range, Rg3 As Range, i&, j&, Tp1, Tp2
Const Raz$ = "* - *", TK$ = " тК ", ZvTKZv$ = "*тК*", Zv$ = "*"
Set Rg1 = Range("B1:C11")
Set Rg2 = Range("F1:F13")
Set Rg3 = Range("A1:A11")
ReDim Tp2(1 To Rg1.Rows.Count)
For i = 2 To Rg1.Rows.Count
If Rg1.Cells(i, 2) Like ZvTKZv Then
    If Rg1.Cells(i, 2) Like Raz Then
        Tp1 = VBA.Split(Rg1.Cells(i, 2), TK)
        For j = 2 To Rg2.Cells.Count
        If Rg2.Cells(j, 1) Like Zv & Tp1(1) & Zv Then Tp2(i) = i: Exit For
        Next j
    Else
        Tp1 = VBA.Split(Rg1.Cells(i, 2), TK)
        For j = 2 To Rg2.Cells.Count
        If Rg2.Cells(j, 1) Like Zv & Tp1(1) & Zv Then Tp2(i) = i: Exit For
        Next j
        
        If Rg1.Cells(i, 1) Like ZvTKZv Then
        Tp1 = VBA.Split(Rg1.Cells(i, 1), TK)
        For j = 2 To Rg2.Cells.Count
        If Rg2.Cells(j, 1) Like Zv & Tp1(1) & Zv Then Tp2(i) = i: Exit For
        Next j
        End If
    End If
End If
Next i
For i = 1 To UBound(Tp2)
If Tp2(i) > 0 Then Rg3.Cells(i, 1).Interior.Color = vbYellow
Next i
End Sub

=СУММЕСЛИМН($B6:$H6;$B$5:$H$5;">="&B$17;$B$5:$H$5;"<="&B$18)

Function Counrows(Яч1 As Range, Яч2 As Range) As Double
Dim ZZ#, i&
Do Until i = 100000
i = i + 1
If Яч1(i) = Яч1 Then ZZ = ZZ + Яч2(i)
If ZZ = 0 Then Exit Do
Loop
Counrows = i
End Function

Sub ParsingTXT()
Dim ArFil, ArIn, ArVih, Tp1, Txt$, ii&, j%, iV1&
Const Kon$ = "*##########", Sl3$ = "///", Raz2% = 20
ArIn = "Files TXT (*.txt),*.txt," & "All Files (*.*),*.*"
ArVih = "Выберите файл и нажмите открыть"
ArFil = Application.GetOpenFilename(ArIn, , ArVih, , False)
If VarType(ArFil) = vbBoolean Then Exit Sub
ArIn = Split(CreateObject("Scripting.FileSystemObject").OpenTextFile(ArFil, 1).ReadAll, vbCrLf)
ReDim ArVih(UBound(ArIn)): For ii = 0 To UBound(ArIn)
If ArIn(ii) Like Kon Then ArVih(iV1) = Txt & ArIn(ii): iV1 = iV1 + 1: Txt = vbNullString Else Txt = Txt & ArIn(ii)
Next
ReDim ArIn(UBound(ArVih), Raz2): For ii = 0 To UBound(ArVih)
Tp1 = VBA.Split(ArVih(ii), Sl3)
For j = 0 To UBound(Tp1): ArIn(ii, j) = Tp1(j): Next j, ii
Range("A2").Resize(UBound(ArIn) + 1, UBound(ArIn, 2) + 1) = ArIn
End Sub

Set xDic = Nothing

Function Summa2(Text$) As Double
Dim Ar1() As Byte, Ar2() As Byte, i&, n&, Fl As Boolean: Const Dob$ = "A"
Ar1 = VBA.StrConv(Text & Dob, vbFromUnicode)
ReDim Ar2(UBound(Ar1))
For i = 0 To UBound(Ar1)
If (Ar1(i) >= 48 And Ar1(i) <= 57) Or Ar1(i) = 44 Then
Ar2(n) = Ar1(i): n = n + 1: Fl = True
Else
If Fl Then
Summa2 = Summa2 + VBA.CDbl(VBA.StrConv(Ar2, vbUnicode))
ReDim Ar2(UBound(Ar1)): Fl = False: n = 0
End If: End If: Next i
End Function

Function Summa(Txt$)
Dim Sum1#, Sim$, i&, n&, Fl As Boolean: Const Zap$ = ",", Dob$ = "A"
Txt = Txt & Dob
For i = 1 To Len(Txt)
Sim = VBA.Mid(Txt, i, 1)
If VBA.IsNumeric(Sim) Or Sim = Zap Then
If Not Fl Then If i > n Then n = i: Fl = True
Else: If Fl Then Sum1 = Sum1 + VBA.CDbl(VBA.Mid(Txt, n, i - n)): Fl = False
End If
Next
Summa = Sum1
End Function

Function StrToDate1(Text As String)
    With CreateObject("VBScript.RegExp")
        .Pattern = "\d{2}[- .].{3,12}\d{4}"
    If .test(Text) Then StrToDate1 = CDate(.Execute(Text)(0)): Exit Function
    End With
End Function

Function StrToDate2(txt)
Dim Arr() As Byte, Arr2() As Byte, n%, k%, i&
Arr = VBA.StrConv(txt, vbFromUnicode)
n = UBound(Arr)
For i = 0 To n
    If Arr(i) >= 48 And Arr(i) <= 57 Then
        If i < n Then n = i
        If i > k Then k = i
    End If
Next i
ReDim Arr2(n To k)
For i = n To k: Arr2(i) = Arr(i): Next
StrToDate2 = VBA.CDate(VBA.StrConv(Arr2, vbUnicode))
End Function

Sub Redesigner()
Dim i&, r&, c%, j%, k%, hc%, hr%, shRez As Worksheet, inData As Range
hr = 1
hc = 1
Application.ScreenUpdating = False
    Set inData = ActiveSheet.Cells(1).CurrentRegion
    Set shRez = Worksheets.Add
     
For r = (hr + 1) To inData.Rows.Count
    For c = (hc + 1) To inData.Columns.Count
    If inData.Cells(r, c) <> "" Then
    i = i + 1
        For j = 1 To hc
            shRez.Cells(i, j) = inData.Cells(r, j)
        Next j
        For k = 1 To hr
            shRez.Cells(i, j + k - 1) = inData.Cells(k, c)
        Next k
        shRez.Cells(i, j + k - 1) = inData.Cells(r, c)
    End If
    Next c
Next r
End Sub

Function StrToDate(txt$)
Dim Arr1: Const Rz$ = " "
Arr1 = VBA.Split(txt, Rz)
For i = 0 To UBound(Arr1)
If VBA.IsNumeric(Arr1(i)) Then Exit For
Next i
StrToDate = VBA.CDate(Arr1(i) & Rz & Arr1(i + 1) & Rz & Arr1(i + 2))
End Function

Sub enstarahgg()
Dim Arr1, Arr2, i&, k&, j%
Arr1 = Selection
For i = 1 To UBound(Arr1)
If Arr1(i, 1) <> vbNullString Then k = k + 1 Else Exit For
Next

ReDim Arr2(1 To UBound(Arr1) * k, 1 To 3): k = 0
Do While Arr1(j + 1, 1) <> vbNullString
j = j + 1
    For i = 1 To UBound(Arr1)
        Arr2(i + k, 1) = Arr1(j, 1)
        Arr2(i + k, 2) = Arr1(j, 2)
        Arr2(i + k, 3) = Arr1(i, 3)
    Next i
k = (i - 1) * j
Loop
Range("J1").Resize(UBound(Arr2), UBound(Arr2, 2)) = Arr2
End Sub

Sub enstaraldfsg()
Dim Tp1, i&, ArByt() As Byte
For Each Tp1 In Selection.Cells
ArByt = VBA.StrConv(Tp1, vbFromUnicode)
For i = 13 To UBound(ArByt)
If ArByt(i) = 48 Then ArByt(i) = 0
Next i
Tp1.Value = VBA.Replace(VBA.StrConv(ArByt, vbUnicode), vbNullChar, vbNullString)
Next
End Sub

Sub enstaraldfsg()
Dim Tp1, i&, ArByt() As Byte
For Each Tp1 In Selection.Cells
ArByt = VBA.StrConv(Tp1, vbFromUnicode)
For i = 0 To UBound(ArByt)
If ArByt(i) < 48 Or ArByt(i) > 57 Then ArByt(i) = 0
Next i
Tp1.Value = VBA.Replace(VBA.StrConv(ArByt, vbUnicode), vbNullChar, vbNullString)
Next
End Sub

=СУММПРОИЗВ((R7:R34>1/1440)*(P7:P34="Телеф."))

Set Rg1 = Range("Таблица1[Данные]")
Set Rg1 = Intersect(Rg1.Offset(1, 0), Rg1)

Set Rg1 = Range("Таблица1[Данные]")
Set Rg1 = Rg1.Resize(Rg1.Rows.Count - 1)

Pob = 0