Поиск по части строки, копирование найденного куска текста и вставка его в ячейку рядом., Список элементов, которые подвергаются п

[autobaryga]

Добрый день!!

Помогите пжл., есть документ XLS, в одной колонке есть общие данные, но мне надо получить только фрагмент текста из этой колонки и поместить их в отдельную колонку.

Например
Диск R18 LS 8.0J 5х130 et48/84.1 MR42 SF Из этого столбца, мне надо скопировать и вынести в 2 отдельных столбца 2 фрагмента (При этом в первом столбце их так же надо оставить)
1. 5х130
2. R18

В параметре 1, есть вероятность, что "х" написана как английская, так может написана и по русски. А значение в новую колонку на доелать в едином формате, т.е. все с английской или русской буквой.

Параметры бывают разные, но их кол-во предсказуемо и можно подставлять для конкретного случая...

Пример файла изначального и конечного во вложении, он в архиве, т.к. вложить формат эксель не получилось....

Буду признателен, если кто то поможет с написанием макроса для оптимизации процесса подготовки прайса., пополню баланс мобилы например

[Казанский]

кросс http://www.planetaexcel.ru/forum/ind...ta-i-vstavka-e
Вы всем пополнять баланс будете?

[EducatedFool]

А у меня есть готовое решение для шин и дисков:
http://excelvba.ru/programmes/Unific...unctions/Tyres

Function RimParameters(ByVal txt$, Optional ByVal Result& = 0) As String
    On Error Resume Next
    ' возвращает значение в зависимости от параметра Result&:
    ' 0 - полный типоразмер, 1 - диаметр диска (DIAM), 2 - ширина диска (WID), 3 - вылет диска (ET),
    ' 4 - количество болтов (WHOLES), 5 - диаметр окружности болтов (PCD - Pitch Circle Diameter),
    ' 6 - разболтовка (BC*PCD), 7 - диаметр отверстия (Centerbore), 8 - цвет (COLOR)

    Dim WID$, PROF$, DIAM$, ET$, WHOLES$, PCD$, CENTERBORE$, COLOR$

    Dim pattern_index&: pattern_index& = -1
    Static REGEXP As Object
    If REGEXP Is Nothing Then Set REGEXP = CreateObject("VBScript.RegExp"): REGEXP.Global = True

    txt$ = Application.Trim(txt$): txt$ = Replace(txt$, ".", ","): txt$ = Replace(txt$, "ЕТ", "ET"): txt$ = Replace(txt$, "DIA", "D")
    txt$ = Replace(txt$, "x ", "`` "): txt$ = Replace(txt$, "х ", "`` "): txt$ = Replace(txt$, ",0,0", ",0")
    txt$ = Replace(txt$, "x", "*"): txt$ = Replace(txt$, "х", "*"): txt$ = Replace(txt$, ";", " ")
    ' Буква J – указывает на наличие одного буртика (хампа). Вместо может так же использоваться маркировка H,Н2,FH,AH
    For Each v In Array("J*", "FH*", "AH*", "H2*", "H*"): txt$ = Replace(txt$, v, "*"): Next

    'txt$ = Replace(txt$, "/98", "*98"): txt$ = Replace(txt$, "/1", "*1")
    REGEXP.Pattern = "/98(\D)": If REGEXP.test(txt$) Then txt$ = REGEXP.Replace(txt$, "*98$1")
    REGEXP.Pattern = "(\d)/1(\d{2})(\D)": If REGEXP.test(txt$) Then txt$ = REGEXP.Replace(txt$, "$1*1$2$3")

    txt$ = Replace(txt$, "/", " ")
    txt$ = Replace(txt$, "* ", "*"): txt$ = Replace(txt$, " *", "*"): txt$ = Replace(txt$, Chr(160), " "): txt$ = Replace(txt$, "|", " ")
    txt = " " & Replace(Replace(txt, "(", " ( "), ")", " ) ") & " "

    ' вылет диска
    REGEXP.Pattern = " ET(\d{1,2},\d|\d{1,2})|ET-(\d{1,2},\d|\d{1,2}) "
    If REGEXP.test(txt$) Then
        ET$ = Trim(Split(REGEXP.Execute(txt$).item(0).value, "ET")(1))
    End If

    ' диаметр отверстия (Centerbore)
    REGEXP.Pattern = " D(\d{2,3},\d|\d{2,3}) "
    If REGEXP.test(txt$) Then
        CENTERBORE$ = Trim(Split(REGEXP.Execute(txt$).item(0).value, "D")(1))
    Else
        REGEXP.Pattern = " (\d{2,3},\d|\d{2,3}) "
        If REGEXP.test(txt$) Then
            CENTERBORE$ = Trim(REGEXP.Execute(txt$).item(0).value)
        End If
    End If

    ' разболтовка
    REGEXP.Pattern = " (3|4|5|6|8|10)\*(98|(\d{3},\d|\d{3})) "
    If REGEXP.test(txt$) Then
        res$ = Trim(REGEXP.Execute(txt$).item(0).value)
        WHOLES$ = Split(Replace(res$, "/", "*"), "*")(0)
        PCD$ = Split(Replace(res$, "/", "*"), "*")(1)
    Else        ' двойная разболтовка типа 10*100*114,3
        REGEXP.Pattern = " (3|4|5|6|8|10)\*(98|(\d{3},\d|\d{3})\*(98|(\d{3},\d|\d{3})) "
        REGEXP.Pattern = " (6|8|10)\*(\d{3},\d|\d{3})\*(\d{3},\d|\d{3}) "
        If REGEXP.test(txt$) Then
            res$ = Trim(REGEXP.Execute(txt$).item(0).value)
            WHOLES$ = Split(Replace(res$, "/", "*"), "*")(0)
            PCD$ = Split(Replace(res$, "/", "*"), "*", 2)(1)
        End If
    End If

    ' ширина и диаметр (могут идти в любом порядке)
    REGEXP.Pattern = " [12][0-9]\*([3-9]|[3-9],5|[3-9],[27]5|1[0-3]|1[0-3],5) "
    If REGEXP.test(txt$) Then
        res$ = Trim(REGEXP.Execute(txt$).item(0).value)
        DIAM$ = Split(Replace(res$, "/", "*"), "*")(0)
        WID$ = Split(Replace(res$, "/", "*"), "*")(1)
    Else
        REGEXP.Pattern = " ([3-9]|[3-9],0|[3-9],5|[3-9],[27]5|1[0-3]|1[0-3],5|1[0-3],[27]5)\*[12][0-9] "
        If REGEXP.test(txt$) Then
            res$ = Trim(REGEXP.Execute(txt$).item(0).value)
            WID$ = Split(Replace(res$, "/", "*"), "*")(0)
            DIAM$ = Split(Replace(res$, "/", "*"), "*")(1)
        Else
            REGEXP.Pattern = " R[12][0-9] "
            If REGEXP.test(txt$) Then
                res$ = Trim(REGEXP.Execute(txt$).item(0).value)
                WID$ = ""
                DIAM$ = Split(res$, "R")(1)
            End If
        End If
    End If


    ' цвет
    REGEXP.Pattern = "\b[A-z]{1,6}\b"
    color_txt$ = Replace(Replace(Replace(txt, "(", " ("), ")", ") "), ",", " ") & " "
    If REGEXP.test(color_txt$) Then
        Set a = REGEXP.Execute(color_txt$)
        COLOR$ = UCase(Trim(REGEXP.Execute(color_txt$).item(REGEXP.Execute(color_txt$).Count - 1).value))
    End If

    FULL_TEXT$ = Application.Trim(Replace(WID$ & "*" & DIAM$ & " / " & WHOLES$ & "*" & PCD$ & " ET" & ET$ & " D" & CENTERBORE$ & " " & COLOR$, "*", "x"))
    If Len(WID$) + Len(DIAM$) + Len(WHOLES$) + Len(PCD$) = 0 Then FULL_TEXT$ = ""

    RimParameters = Choose(Result& + 1, FULL_TEXT$, DIAM$, WID$, ET$, WHOLES$, PCD$, IIf(Len(WHOLES$) * Len(PCD$), WHOLES$ & "*" & PCD$, ""), CENTERBORE$, COLOR$)
End Function

[autobaryga]

Спасибо за ответы, что то не могу разобраться с применением макроса...

У меня офисе 2003, эти коды макроса под него пойдут или все равно?