Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Поиск по части строки, копирование найденного куска текста и вставка его в ячейку рядом
 
Добрый день!!

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

Пример файла изначального и конечного во вложении
Буду признателен, если кто то поможет с написанием макроса для оптимизации процесса подготовки прайса., пополню баланс мобилы например
Изменено: Autobaryga - 29 Мар 2015 13:22:34
 
Код
Sub ikki()
  Dim r As Object, i&, s$, m As Object, a(), b$()
  Set r = CreateObject("vbscript.regexp"): r.Global = True: r.ignorecase = False
  r.Pattern = "(R\d\d|\d\d[xх]).*?(\d[xх]\d+)"
  a = [a1].CurrentRegion.Value
  ReDim b(1 To UBound(a), 1 To 2)
  For i = 1 To UBound(a)
    Set m = r.Execute(a(i, 2))
    If m.Count Then
      b(i, 1) = m(0).submatches(0)
      If Left(b(i, 1), 1) <> "R" Then b(i, 1) = "R" & Left(b(i, 1), Len(b(i, 1)) - 1)
      b(i, 2) = Replace(m(0).submatches(1), "х", "x")
    End If
  Next
  [d1].Resize(UBound(b), 2).Value = b
End Sub
фрилансер Excel, VBA - контакты в профиле
"Совершенствоваться не обязательно. Выживание — дело добровольное." Э.Деминг
 
Код
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


Пример результата (с использованием этой функции в качестве формулы) — в прикреплённом файле

Код взят из этой программы:
http://excelvba.ru/programmes/Unification/FieldFunctions/Tyres
Изменено: Игорь - 28 Мар 2015 12:17:00
 
У меня получилось не так изящно, но вроде работает (UDF, а не макрос):
Код
Function tt(S As String, Num As Integer) As String
Dim aStr
Dim aStr1 As String, aNum As Integer
If InStr(S, "Диск") = 0 Then Exit Function
aStr1 = Replace(S, "Диск ", "")
aStr = Split(aStr1)
If (Num - 1) > UBound(aStr) Then Exit Function
aNum = Num
For I = 0 To UBound(aStr)
    If aStr(I) Like "R" & "??" Or aStr(I) Like "*литой*" _
    Or aStr(I) Like "*" & "[0-9]" & "x" & "*" Then
    If aNum = 1 Then
    tt = aStr(I)
    Exit Function
    Else: aNum = aNum - 1
    End If
    End If
Next I
End Function

 
Цитата
МВТ написал: UDF, а не макрос
Я еще не разобрался как предложенные коды макроса использовать, т.е. как их поместить, а Вы уже что то новое прислали.:D
Изменено: Autobaryga - 29 Мар 2015 13:22:48
 
а что там разбираться?
я же прикрепил пример файла с макросом (см. формулы во 2 и 3 столбцах)
 
Игорь, В общем сделал проще... скопировал весь прайс в Ваш файл, получилось неплохо, но по некоторым строкам есть проблемы.
Почти полный файл во вложении.
Где то только буква R прописалась, разболтовка с данными после слэша, разболтовка не прописана.
 
Игорь, И вот еще один прайс, с ним не прошла та формула....
 
Не существует формулы, которая подойдёт для любого случая
Иногда, исходные данные надо предварительно обработать, перед использованием формулы
Именно для этого я и сделал программу для прайсов:
http://excelvba.ru/programmes/Unification

в вашем случае, размер не определяется из-за нестандартной записи вида 17x7,0
(правильно было бы 17x7 )

Т.е. решить проблему можно, выделив первый столбец (с исходными данными),
и заменив (нажав Ctrl + H) текст «.0 » на « »
(точка-ноль-пробел меняем на пробел)
 
Игорь, Посмотрел программу, там для меня еще сложнее чем в Эксель :D
Прога наверно норм, но не смог в ней разобраться...

Дальше напишу в ЛС
 
ikki, МВТ, Спасибо Вам! Но мне проще по схеме Игоря, специализация....

Жду номера мобил в ЛС, как и обещал, пополню немного ;)
 
ikki, Подскажите, что надо изменить в формуле, что параметр 5х114.3 учитывал? В нынешнем коде, прописывает только 5x114. Спасибо.
 
Цитата
МВТ написал:  (UDF, а не макрос):
Этот код куда размещать?
 
Вопрос актуален, требуется оптимизация прайс листов, тематика автошины, диски колесные, аккумуляторы и авто масла. 2 поставщика, т.е. 8 прайсов пока что

Взять данные из контекста прайса и вынести в отдельную колонку.

Вышлю образцы прайсов по запросу. Спасибо. Бюджет 1500 руб.
Страницы: 1
Читают тему (гостей: 1)