Multi Split

Dirty Version

В этой версии все строки разделены и записаны с использованием принципа «одна ячейка в одну (другую) ячейку».

Sub MultiSplit()

    Const cDel As String = ";,/"  ' Delimiter List
    Const cCol1 As Variant = "A"  ' Source Column Letter/Number
    Const cCol2 As Variant = "B"  ' Target Column Letter/Number
    Const cDelR As String = ","   ' Replace Delimiter
    Const cFirstR As Long = 1     ' First Row Number

    Dim vntR As Variant   ' Range Array
    Dim vntD As Variant   ' Delimiter Array

    Dim LastR As Long     ' Last Row Number
    Dim i As Long         ' Range Array Row Counter
    Dim j As Long         ' Delimiter Array Row Counter

    ' Calculate Last Row Number.
    LastR = Cells(Rows.Count, cCol1).End(xlUp).Row

    ' Copy Source Range into Range Array.
    vntR = Range(Cells(cFirstR, cCol1), Cells(LastR, cCol1))

    ' Split Delimiter List into Delimiter Array
    vntD = Split(cDel, ",")

    ' Calculate values in Range Array.
    For i = 1 To UBound(vntR) ' Range Array
        For j = 0 To UBound(vntD) ' Delimiter Array
            ' Replace by overwriting.
            vntR(i, 1) = Replace(vntR(i, 1), vntD(j), cDelR)
        Next
    Next

    ' Copy Range Array to Target Range.
    Range(Cells(cFirstR, cCol2), Cells(LastR, cCol2)) = vntR

End Sub

Версия Clean One String

Если вы хотите, чтобы все билеты AK1 находились в одной ячейке, используйте следующий код. Настройте cDelC (конечный разделитель) в соответствии со своими потребностями (например, aa, aa или aa, aa).

Sub MultiSplit2()

    Const cDel As String = ";,/"     ' Delimiter List
    Const cCol1 As Variant = "A"     ' Source Column Letter/Number
    Const cCol2 As Variant = "B"     ' Target Column Letter/Number
    Const cDelR As String = ","      ' Replace Delimiter
    Const cFirstR As Long = 1        ' First Row Number
    Const cDelC As String = ", "     ' Clean Delimiter
    Const cString As String = "AK1"  ' Desired Start String

    Dim vntR As Variant   ' Range Array
    Dim vntD As Variant   ' Delimiter Array
    Dim vntT As Variant   ' Temporary Array

    Dim LastR As Long     ' Last Row Number
    Dim i As Long         ' Range Array Row Counter
    Dim j As Long         ' Delimiter Array Row Counter
    Dim strT As String    ' Target String


    ' Calculate Last Row Number.
    LastR = Cells(Rows.Count, cCol1).End(xlUp).Row

    ' Copy Source Range into Range Array.
    vntR = Range(Cells(cFirstR, cCol1), Cells(LastR, cCol1))

    ' Split Delimiter List into Delimiter Array
    vntD = Split(cDel, ",")

    ' Calculate values in Range Array.
    For i = 1 To UBound(vntR) ' Range Array
        For j = 0 To UBound(vntD) ' Delimiter Array
            ' Replace by overwriting.
            vntR(i, 1) = Replace(vntR(i, 1), vntD(j), cDelR)
        Next
        Debug.Print vntR(i, 1)
    Next

    ' Clean the strings in Range Array.
    For i = 1 To UBound(vntR)
        vntT = Split(vntR(i, 1), cDelR)
        For j = 0 To UBound(vntT)
            If Left(Trim(vntT(j)), Len(cString)) = cString Then
                If strT <> "" Then
                    strT = strT & cDelC & Trim(vntT(j))
                  Else
                    strT = Trim(vntT(j))
                End If
            End If
        Next
    Next

    ' Copy Target String to Target Cell.
    Cells(cFirstR, cCol2) = strT

End Sub

Я предлагаю сделать это с помощью пользовательской функции (UDF). Установите приведенный ниже код в стандартный модуль кода (нажмите Alt + F11, чтобы открыть окно редактора VB. Щелкните правой кнопкой мыши проект VBA в окне проводника проекта на слева выберите «Вставка»> «Модуль» и вставьте код в пустую панель кода справа. Не забудьте сохранить книгу в формате xlsm (с поддержкой макросов).

Function ExtractAK1(Cell As Range) As String

    Const AK1 As String = "AK1-"

    Dim Var As Variant
    Dim Sp() As String
    Dim i As Integer

    Var = Cell.Value
    If VarType(Var) = vbString Then
        If InStr(1, Var, AK1, vbTextCompare) Then
            Sp = Split(Trim(Var), AK1)
            For i = 1 To UBound(Sp)
                Sp(i) = AK1 & Left(Trim(Sp(i)), 5)
            Next i
            Var = Join(Sp, ",")
            ExtractAK1 = Mid(Var, InStr(Var, ",") + 1)
        End If
    End If
End Function

Вызовите функцию на листе. как вы бы вызвали встроенную функцию Excel, например,

=ExtractAK1($A2)

При правильной установке Excel предложит имя функции, когда вы начнете вводить ее. $ A2 - это ячейка, содержащая ваш текст. Скопируйте Формула вниз столько, сколько нужно. Вы можете переопределить функцию для использования в цикле, если это более удобный способ ее использования.

Следующая UDF извлечет все, что вы вводите, в список с разделителями-запятыми только из AK номеров билетов. Предполагается, что за шаблоном номера билета следует AK-, за которым следуют только цифры, что вы и показываете. Извлекаются только номера билетов и то, что вы говорите, что хотите.

• Если вы введете одну строку или одну ячейку, это содержимое появится.
• Если вы введете диапазон ячеек, они будут объединены в одну строку вывода.
• Механизм регулярных выражений VBA используется для извлечения номеров билетов

Option Explicit
  Public RE As Object
  Public MC As Object
  Public M As Object

    'Assume starts with AK- and ends with numbers
    '  as per your example
 Public Const sPat As String = "\bAK1-\d+"

Function getAK(vIN As Variant) As String
    Dim V As Variant
    Dim sTemp As String

Set RE = CreateObject("vbscript.regexp")
With RE
    .Pattern = sPat
    .ignorecase = False
    .Global = True
End With

If IsArray(vIN) Then
    For Each V In vIN
        sTemp = sTemp & "," & getStrOnly(CStr(V))
    Next V
Else
    getAK = getStrOnly(CStr(vIN))
    Exit Function
End If

getAK = Mid(sTemp, 2)

End Function

Private Function getStrOnly(str As String) As String
    Dim sTemp As String
    With RE
        If .test(str) = True Then
            Set MC = .Execute(str)
            For Each M In MC
                sTemp = sTemp & "," & M
            Next M
        End If
    End With
    getStrOnly = Mid(sTemp, 2)
End Function

Использование версии для одной ячейки: getAK(A1):

[118 ]

Используя метод нескольких ячеек:

=getAK(A1:A12)

мы получаем

AK1-97760,AK1-96767,AK1-97719,AK1-97999,AK1-98105,,AK1-97113,AK1-97073,AK1-97019,AK1-97951,AK1-97858,AK1-97195,AK1-96806,AK1-97719,AK1-97896,AK1-98115,AK1-98151,AK1-98089,AK1-96780,AK1-90919,AK1-96705,AK1-96806,AK1-95397

Если вы также хотите вернуть статус заявки (часть в скобках после номера заявки), вы можете изменить регулярное выражение на:

"\bAK1-\d+(?:\s*\([^)]+\))?"

И если ваши шаблоны заявок отличаются, вы также можете соответствующим образом изменить регулярное выражение.