Private Function regexpseparate(s As Variant)
    Dim Sl As String, bRes As Boolean, RegExp As Object, oMatches As Object, n As Integer, p As String
    
    Sl = ""
    ReDim x(1) As String
    bRes = False
    Set RegExp = CreateObject("VBScript.RegExp")
    RegExp.Global = True
    RegExp.IgnoreCase = True
    RegExp.Pattern = TextBox1.Text
    bRes = RegExp.test(s)
      If ComboBox1.Text = "" Then
      p = 0
         Else
         p = ComboBox1.Text
    End If
    If bRes Then
     Set oMatches = RegExp.Execute(s)
     '  ReDim X(oMatches.Count)
        If p = 0 Or p > 5 Then
            Sl = oMatches(0)
            For n = 1 To oMatches.Count - 1
            Sl = Sl & oMatches(n)
            Next
        ElseIf p = 1 Then
            Sl = oMatches(0).subMatches(0) & TextBox2.Text
            For n = 1 To oMatches.Count - 1
            Sl = Sl & oMatches(n).subMatches(0) & TextBox2.Text
            Next
        ElseIf p = 2 Then
            Sl = oMatches(0).subMatches(0) & TextBox2.Text & oMatches(0).subMatches(1)
            For n = 1 To oMatches.Count - 1
            Sl = Sl & oMatches(n).subMatches(0) & TextBox2.Text & oMatches(n).subMatches(1)
            Next
        ElseIf p = 3 Then
            Sl = oMatches(0).subMatches(0) & TextBox2.Text & oMatches(0).subMatches(1) & TextBox2.Text & oMatches(0).subMatches(2)
            For n = 1 To oMatches.Count - 1
            Sl = Sl & oMatches(n).subMatches(0) & TextBox2.Text & oMatches(n).subMatches(1) & TextBox2.Text & oMatches(n).subMatches(2)
            Next
        ElseIf p = 4 Then
            Sl = oMatches(0).subMatches(0) & TextBox2.Text & oMatches(0).subMatches(1) & TextBox2.Text & oMatches(0).subMatches(2) & TextBox2.Text & oMatches(0).subMatches(3)
            For n = 1 To oMatches.Count - 1
            Sl = Sl & oMatches(n).subMatches(0) & TextBox2.Text & oMatches(n).subMatches(1) & TextBox2.Text & oMatches(n).subMatches(2) & TextBox2.Text & oMatches(n).subMatches(3)
            Next
        ElseIf p = 5 Then
            Sl = oMatches(0).subMatches(0) & TextBox2.Text & oMatches(0).subMatches(1) & TextBox2.Text & oMatches(0).subMatches(2) & TextBox2.Text & oMatches(0).subMatches(3) & TextBox2.Text & oMatches(0).subMatches(4)
            For n = 1 To oMatches.Count - 1
            Sl = Sl & oMatches(n).subMatches(0) & TextBox2.Text & oMatches(n).subMatches(1) & TextBox2.Text & oMatches(n).subMatches(2) & TextBox2.Text & oMatches(n).subMatches(3) & TextBox2.Text & oMatches(n).subMatches(4)
            Next
        End If
    s = RegExp.Replace(s, "")
    End If
    x(0) = Sl: x(1) = s
    regexpseparate = x
End Function

Private Sub ComboBox1_DropButtonClick()
ComboBox1.List = Array("1", "2", "3", "4", "5")
ComboBox1.style = fmStyleDropDownList
End Sub

Private Sub CommandButton1_Click()
    On Error GoTo Error
    'объявляем переменные
    Dim R, c
    Dim M(), RZ(), U() As String

    'считываем в маассив данные
    M = ActiveSheet.Range("A1:A" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row).Value
    'здесь RZ - массив. в который записываются значения, которые потом будут выгружены на лист.
    '+3 - это на сколько столбцов этот массив больше, чем исходный
    ReDim RZ(1 To UBound(M), 1 To UBound(M, 2) + 2)
    'перебираем все строки массива
    For R = 1 To UBound(M)
    RZ(R, 1) = M(R, 1)
     ' ищем мобильные операторы
     c = regexpseparate(M(R, 1))
     RZ(R, 2) = c(0)
    
    Next R
    Range("A1").Resize(UBound(RZ), UBound(RZ, 2)) = RZ
    Cells.Columns.AutoFit
    Cells.Rows.AutoFit
    GoTo Skip
Error:
    MsgBox "Неправильное регулярное выражение или неправильно количество групп", vbCritical, "Ошибка"
Skip:
    Unload Me
End Sub

Private Sub Label1_Click()

End Sub

Private Sub TextBox1_Change()

End Sub

Private Sub TextBox2_Change()

End Sub
 

Private Function regexpseparate(s As Variant)
    Dim Sl As String, bRes As Boolean, RegExp As Object, oMatches As Object, n As Integer
    Sl = ""
    ReDim x(1) As String
    bRes = False
    Set RegExp = CreateObject("VBScript.RegExp")
    RegExp.Global = True
    RegExp.IgnoreCase = True
    RegExp.Pattern = "TextBox1.Text"
    bRes = RegExp.test(s)
    If bRes Then
     Set oMatches = RegExp.Execute(s)
     '  ReDim X(oMatches.Count)
     Sl = oMatches(0).subMatches(0) & oMatches(0).subMatches(1) & oMatches(0).subMatches(2) & oMatches(0).subMatches(3)
      For n = 1 To oMatches.Count - 1
      Sl = Sl & oMatches(n).subMatches(0) & oMatches(n).subMatches(1) & oMatches(n).subMatches(2) & oMatches(n).subMatches(3)
     Next
     s = RegExp.Replace(s, "")
    End If
    x(0) = Sl: x(1) = s
    regexpseparate = x
End Function
Private Sub CommandButton1_Click()
    'объявляем переменные
    Dim R, c
    Dim M(), RZ(), U() As String

    'считываем в маассив данные
    M = ActiveSheet.Range("A1:A" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row).Value
    'здесь RZ - массив. в который записываются значения, которые потом будут выгружены на лист.
    '+3 - это на сколько столбцов этот массив больше, чем исходный
    ReDim RZ(1 To UBound(M), 1 To UBound(M, 2) + 2)
    'перебираем все строки массива
    For R = 1 To UBound(M)
    RZ(R, 1) = M(R, 1)
     ' ищем мобильные операторы
     c = regexpseparate(M(R, 1))
     RZ(R, 2) = c(0)

    Next R
    Range("A1").Resize(UBound(RZ), UBound(RZ, 2)) = RZ
    Cells.Columns.AutoFit
    Cells.Rows.AutoFit
    Unload Me
End Sub

Private Sub Label1_Click()

End Sub

Private Sub TextBox1_Change()

End Sub 

Private Function regseparate(s As Variant)
    Dim Sl As String, bRes As Boolean, RegExp As Object, oMatches As Object, n As Integer
    Sl = ""
    ReDim x(1) As String
    
    Dim reg As String
    reg = Application.InputBox("Введите ваше регулярное выражение", "RegExp", Type:=2)
    
    bRes = False
    Set RegExp = CreateObject("VBScript.RegExp")
    RegExp.Global = True
    RegExp.IgnoreCase = True
    RegExp.Pattern = "reg"
    bRes = RegExp.test(s)
    If bRes Then
     Set oMatches = RegExp.Execute(s)
     '  ReDim X(oMatches.Count)
     Sl = oMatches(0).subMatches(0) & oMatches(0).subMatches(1) & oMatches(0).subMatches(2) & oMatches(0).subMatches(3)
      For n = 1 To oMatches.Count - 1
      Sl = Sl & oMatches(n).subMatches(0) & oMatches(n).subMatches(1) & oMatches(n).subMatches(2) & oMatches(n).subMatches(3)
     Next
     s = RegExp.Replace(s, "")
    End If
    x(0) = Sl: x(1) = s
    regseparate = x
End Function
Public Sub RegExpSeparate(control As IRibbonControl)
    'объявляем переменные
    Dim R, c
    Dim M(), RZ(), U() As String
    'считываем в маассив данные
    M = ActiveSheet.Range("A1:A" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row).Value
    'здесь RZ - массив. в который записываются значения, которые потом будут выгружены на лист.
    '+3 - это на сколько столбцов этот массив больше, чем исходный
    ReDim RZ(1 To UBound(M), 1 To UBound(M, 2) + 2)
    'перебираем все строки массива
    For R = 1 To UBound(M)
    RZ(R, 1) = M(R, 1)
     ' ищем мобильные операторы
     c = regseparate(M(R, 1))
     RZ(R, 2) = c(0)

    Next R
    Range("A1").Resize(UBound(RZ), UBound(RZ, 2)) = RZ
    Cells.Columns.AutoFit
    Cells.Rows.AutoFit
End Sub 

Attribute VB_Name = "allFunc"
Option Explicit
Private Function мобила(s As Variant)
    Dim Sl As String, bRes As Boolean, RegExp As Object, oMatches As Object, n As Integer
    s = Replace(s, " ", "")
    s = Replace(s, "-", "")
    Sl = ""
    ReDim X(1) As String
    bRes = False
    Set RegExp = CreateObject("VBScript.RegExp")
    RegExp.Global = True
    RegExp.IgnoreCase = True
    RegExp.Pattern = "\(?(039|050|063|066|067|068|091|092|093|094|095|096|097|098|099)\)?(\d{3})(\d{2})(\d{2}),?"
    bRes = RegExp.test(s)
    If bRes Then
     Set oMatches = RegExp.Execute(s)
     '  ReDim X(oMatches.Count)
     Sl = "(" & oMatches(0).subMatches(0) & ") " & oMatches(0).subMatches(1) & "-" & oMatches(0).subMatches(2) & "-" & oMatches(0).subMatches(3)
      For n = 1 To oMatches.Count - 1
      Sl = Sl & ", (" & oMatches(n).subMatches(0) & ") " & oMatches(n).subMatches(1) & "-" & oMatches(n).subMatches(2) & "-" & oMatches(n).subMatches(3)
     Next
     s = RegExp.Replace(s, "")
    End If
    X(0) = Sl: X(1) = "'" & s
    мобила = X
End Function
Private Function cityNumber(s As Variant)
    Dim Sl As String, bRes As Boolean, RegExp As Object, oMatches As Object, n As Integer
    s = Replace(s, " ", "")
    s = Replace(s, "-", "")
    s = Replace(s, "(", "")
    s = Replace(s, ")", "")
    s = Replace(s, ",", "")
    Sl = ""
    ReDim X(1) As String
    bRes = False
    Set RegExp = CreateObject("VBScript.RegExp")
    RegExp.Global = True
    RegExp.IgnoreCase = True
    RegExp.Pattern = ",?(\d{3})(\d{3})(\d{2})(\d{2}),?"
    bRes = RegExp.test(s)
    If bRes Then
     Set oMatches = RegExp.Execute(s)
     '  ReDim X(oMatches.Count)
     Sl = "(" & oMatches(0).subMatches(0) & ") " & oMatches(0).subMatches(1) & "-" & oMatches(0).subMatches(2) & "-" & oMatches(0).subMatches(3)
      For n = 1 To oMatches.Count - 1
      Sl = Sl & ", (" & oMatches(n).subMatches(0) & ") " & oMatches(n).subMatches(1) & "-" & oMatches(n).subMatches(2) & "-" & oMatches(n).subMatches(3)
     Next
     s = RegExp.Replace(s, "")
    End If
    X(0) = Sl: X(1) = "'" & s
    cityNumber = X
End Function
Private Function Town(s As Variant)
    Dim Sl As String, bRes As Boolean, RegExp As Object, oMatches As Object, n As Integer
    Sl = ""
    ReDim X(1) As String
    bRes = False
    Set RegExp = CreateObject("VBScript.RegExp")
    RegExp.Global = True
    RegExp.IgnoreCase = True
    RegExp.Pattern = "\d{5},(.*?),"
    bRes = RegExp.test(s)
    If bRes Then
     Set oMatches = RegExp.Execute(s)
     '  ReDim X(oMatches.Count)
     Sl = oMatches(0).subMatches(0)
      For n = 1 To oMatches.Count - 1
      Sl = Sl & ", " & oMatches(n).subMatches(0)
     Next
     s = RegExp.Replace(s, "")
    End If
    X(0) = Sl: X(1) = "'" & s
    Town = X
End Function
Public Sub QWERT()
    Dim R, c, i, p, j
    Dim OD: Set OD = CreateObject("Scripting.Dictionary")
    Dim T: Set T = CreateObject("Scripting.Dictionary")
    Dim M(), RZ(), U() As String

    'считываем в маассив данные
    With Лист1
     M = .Range("A1:G" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    End With
    ReDim RZ(1 To UBound(M), 1 To UBound(M, 2) + 5)
    'перебираем все строки массива
    For R = 1 To UBound(M)
     '    отделяеем название фирмы
            p = InStrRev(M(R, 1), ",")
            If p > 0 Then
                RZ(R, 1) = Left(M(R, 1), p - 1)
                RZ(R, 2) = Trim(Mid(M(R, 1), p + 1))
            Else
                RZ(R, 1) = M(R, 1)
           End If
     ' Переносим неменяемую инфу в соседние незанятые столбцы (где М - существующий столбец) (где RZ -новый)
     ' здесь R - номер строки, 1 - номер столбца
     RZ(R, 7) = M(R, 4)
     RZ(R, 8) = M(R, 5)
     RZ(R, 9) = M(R, 6)
     RZ(R, 10) = M(R, 7)
    
    ' ищем города
    ' T- переменная, Town-название функции, M(R,2) диапозон исходной таблицы в которой ищем инфу
     T = Town(M(R, 2))
     RZ(R, 3) = T(0)
     RZ(R, 4) = T(1)

     ' ищем мобильные операторы
     U = мобила(M(R, 3))
     c = cityNumber(M(R, 3))
     RZ(R, 5) = U(0)
     RZ(R, 6) = c(0)

    Next R
    Worksheets.Add
    Range("A1").Resize(UBound(RZ), UBound(RZ, 2)) = RZ
    Cells.Columns.AutoFit
    Cells.Rows.AutoFit
End Sub 

Attribute VB_Name = "SplitNumber"
Option Explicit
Private Function мобила(S As Variant)
    Dim Sl As String, bRes As Boolean, RegExp As Object, oMatches As Object, n As Integer
    S = Replace(S, " ", "")
    S = Replace(S, "-", "")
    Sl = ""
    ReDim X(1) As String
    bRes = False
    Set RegExp = CreateObject("VBScript.RegExp")
    RegExp.Global = True
    RegExp.IgnoreCase = True
    RegExp.Pattern = "\(?(039|050|063|066|067|068|091|092|093|094|095|096|097|098|099)\)?(\d{3})(\d{2})(\d{2}),?"
    bRes = RegExp.test(S)
    If bRes Then
     Set oMatches = RegExp.Execute(S)
     '  ReDim X(oMatches.Count)
     Sl = "(" & oMatches(0).subMatches(0) & ") " & oMatches(0).subMatches(1) & "-" & oMatches(0).subMatches(2) & "-" & oMatches(0).subMatches(3)
      For n = 1 To oMatches.Count - 1
      Sl = Sl & ", (" & oMatches(n).subMatches(0) & ") " & oMatches(n).subMatches(1) & "-" & oMatches(n).subMatches(2) & "-" & oMatches(n).subMatches(3)
     Next
     S = RegExp.Replace(S, "")
    End If
    X(0) = Sl: X(1) = "'" & S
    мобила = X
End Function
Private Function cityNumber(S As Variant)
    Dim Sl As String, bRes As Boolean, RegExp As Object, oMatches As Object, n As Integer
    S = Replace(S, " ", "")
    S = Replace(S, "-", "")
    S = Replace(S, "(", "")
    S = Replace(S, ")", "")
    S = Replace(S, ",", "")
    Sl = ""
    ReDim X(1) As String
    bRes = False
    Set RegExp = CreateObject("VBScript.RegExp")
    RegExp.Global = True
    RegExp.IgnoreCase = True
    RegExp.Pattern = ",?(\d{3})(\d{3})(\d{2})(\d{2}),?"
    bRes = RegExp.test(S)
    If bRes Then
     Set oMatches = RegExp.Execute(S)
     '  ReDim X(oMatches.Count)
     Sl = "(" & oMatches(0).subMatches(0) & ") " & oMatches(0).subMatches(1) & "-" & oMatches(0).subMatches(2) & "-" & oMatches(0).subMatches(3)
      For n = 1 To oMatches.Count - 1
      Sl = Sl & ", (" & oMatches(n).subMatches(0) & ") " & oMatches(n).subMatches(1) & "-" & oMatches(n).subMatches(2) & "-" & oMatches(n).subMatches(3)
     Next
     S = RegExp.Replace(S, "")
    End If
    X(0) = Sl: X(1) = "'" & S
    cityNumber = X
End Function
Private Function Town(S As Variant)
    Dim Sl As String, bRes As Boolean, RegExp As Object, oMatches As Object, n As Integer
    Sl = ""
    ReDim X(1) As String
    bRes = False
    Set RegExp = CreateObject("VBScript.RegExp")
    RegExp.Global = True
    RegExp.IgnoreCase = True
    RegExp.Pattern = "\d{5},(.*?),"
    bRes = RegExp.test(S)
    If bRes Then
     Set oMatches = RegExp.Execute(S)
     '  ReDim X(oMatches.Count)
     Sl = oMatches(0).subMatches(0)
      For n = 1 To oMatches.Count - 1
      Sl = Sl & ", " & oMatches(n).subMatches(0)
     Next
     S = RegExp.Replace(S, "")
    End If
    X(0) = Sl: X(1) = "'" & S
    Town = X
End Function
Public Sub QWERT()
    Dim R, C, i
    Dim OD: Set OD = CreateObject("Scripting.Dictionary")
    Dim T: Set T = CreateObject("Scripting.Dictionary")
    Dim M(), RZ(), U() As String
    Dim MB
    'считываем в маассив данные
    With Лист1
     M = .Range("A1:G" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    End With
    ReDim RZ(1 To UBound(M), 1 To UBound(M, 2) + 2)
    'перебираем все строки массива
    For R = 1 To UBound(M)
     '    отделяеем название фирмы
     If InStr(1, M(R, 1), ",") > 0 Then
      C = Split(M(R, 1), ",")(0)
      RZ(R, 1) = C
      RZ(R, 2) = Replace(M(R, 1), C & ",", "")
     Else
      RZ(R, 1) = M(R, 1)
     End If
     RZ(R, 3) = M(R, 2)
     RZ(R, 5) = M(R, 2)
               ' ищем города
     T = Town(M(R, 2))
     RZ(R, 3) = T(0)
     RZ(R, 4) = T(1)
     ' ищем мобильные операторы
     U = мобила(M(R, 3))
     C = cityNumber(M(R, 3))
     RZ(R, 5) = U(0)
     RZ(R, 6) = C(0)
     For i = 5 To UBound(M, 2)
      RZ(R, i + 2) = M(R, i)
     Next i
    Next R
    Worksheets.Add
    Range("A1").Resize(UBound(RZ), UBound(RZ, 2)) = RZ
    Cells.Columns.AutoFit
    Cells.Rows.AutoFit
End Sub