Вытащить содержимое из ячейки и записать в столбцы

[kutt]

Необходимо вытащить содержимое текстовой ячейки и записать в столбцы:

Готовый пример сделанный в ручную во вложении:

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

Например:

в ячейке А1 содержиться текст: COMPETITION STI 10W40 (1L) Масло мот. полусинт.

нам нужно вытащить и записать в соседние ячейки текст

в ячейку B1 добавим только: 10W-40 - добавим знак "-"

в ячейку C1 добавим только цифру: 1 - уберем "L" нужна просто цифра

в ячейку D1 добавим только нужный текст: полусинт. - так и оставим нужный текст

и так далее, во вложении готовый ручной вариант.

готов кинуть 200 руб на пиво)))) думаю задача не сильно сложная но мне очень нужная сегодня

[Казанский]

Функция возвращает массив из трех значений, вводить как формулу массива

Function Kutt(s$) As Variant()
Dim u&, d$()
  d = Split(WorksheetFunction.Trim(s))
  u = UBound(d)
  If u > 3 Then
    ReDim f(0 To 2)
    If d(u) Like "полус*" Then
      f(2) = "полусинтетика"
    ElseIf d(u) Like "мин*" Then
      f(2) = "минеральное"
    ElseIf d(u) Like "синт*" Then
      f(2) = "синтетика"
    End If
    f(1) = Val(Mid$(d(u - 3), 2))
    f(0) = Replace(d(u - 4), "w", "w-", , , vbTextCompare)
  End If
  Kutt = f
End Function

[kutt]

Сообщение от Казанский

Функция возвращает массив из трех значений, вводить как формулу массива

Function Kutt(s$) As Variant()
Dim u&, d$()
  d = Split(WorksheetFunction.Trim(s))
  u = UBound(d)
  If u > 3 Then
    ReDim f(0 To 2)
    If d(u) Like "полус*" Then
      f(2) = "полусинтетика"
    ElseIf d(u) Like "мин*" Then
      f(2) = "минеральное"
    ElseIf d(u) Like "синт*" Then
      f(2) = "синтетика"
    End If
    f(1) = Val(Mid$(d(u - 3), 2))
    f(0) = Replace(d(u - 4), "w", "w-", , , vbTextCompare)
  End If
  Kutt = f
End Function

Спасибо за функцию, отблагодарил на кошелек в подписи!!!

Еще небольшой вопрос: Как эту функцию вставить в нужный мне файл? ))))

[Казанский]

Alt+F11 (редактор VBA), Insert - Module, вставить код.
Да, и первой строкой модуля (перед функцией) поставьте эту строку, чтобы оператор Like работал с прописными и строчными буквами.

Option Compare Text

[kutt]

Сообщение от Казанский

Alt+F11 (редактор VBA), Insert - Module, вставить код.
Да, и первой строкой модуля (перед функцией) поставьте эту строку, чтобы оператор Like работал с прописными и строчными буквами.

Option Compare Text

Можно еще небольшой вопрос:

продолжил этот файл примера добавив нужные мне строки, но почему то далее 12 строки выводиться уже все не по сценарию, во вложении готовый файл, если есть возможность, посмотрите пожалуйста, может я что делаю не так?))

[IgorGO]

при активном листе с данными выполните этот

Sub SplitTxt()
  Dim r&, re, s$, res$
  Set re = CreateObject("vbscript.RegExp")
  r = 2
  Do While Not IsEmpty(Cells(r, 1))
    s = Cells(r, 1).Value:  re.Pattern = "\d+W\d+"
    If re.test(s) Then res = re.Execute(s)(0):  Cells(r, 2) = Left(res, InStr(res, "W")) & "-" & Right(res, Len(res) - InStr(res, "W"))
    re.Pattern = "\d+L"
    If re.test(s) Then
      res = re.Execute(s)(0):  Cells(r, 4) = Right(s, Len(s) - InStrRev(s, " ")): Cells(r, 3) = Left(res, Len(res) - 1)
    End If
    r = r + 1
  Loop
End Sub