Как разделить текст по столбцам в Excel с помощью формулы? Отличие в том, что надо вытащить из одной ячейки множество значений. В каждой ячейке значение разные.
В результате хотелось бы получить следующее: Столбец - 3RT2018-2XF42-0LA2 Столбец - 3 ШТ Столбец - 3RH2362-2AF00 Столбец - 3 ШТ Столбец - 3RH2140-1AF00 Столбец - 12 ШТ Столбец - 3RH2122-2XF40-0LA2 Столбец - 3 ШТ
Как разделить текст по столбцам в Excel с помощью формулы? Отличие в том, что надо вытащить из одной ячейки множество значений. В каждой ячейке значение разные.
Добрый день В примере всего одна строка (маловато для тестов) с помощью UDF'ки
Код
=ЕСЛИОШИБКА(Harry($B$3;СТОЛБЕЦ(A1));"")
[vba]
Код
Function Harry(txt As String, i As Integer) i = (i - 1) * 2 arr = Split(Replace(txt, "|", ";"), ";") With CreateObject("VBScript.RegExp") .Global = True .Pattern = "[А-Яа-я; :|-]" Harry = .Replace(arr(i), "") End With End Function
[/vba]
Добрый день В примере всего одна строка (маловато для тестов) с помощью UDF'ки
Код
=ЕСЛИОШИБКА(Harry($B$3;СТОЛБЕЦ(A1));"")
[vba]
Код
Function Harry(txt As String, i As Integer) i = (i - 1) * 2 arr = Split(Replace(txt, "|", ";"), ";") With CreateObject("VBScript.RegExp") .Global = True .Pattern = "[А-Яа-я; :|-]" Harry = .Replace(arr(i), "") End With End Function
Harry, еще вариант макроса для исходного(первого) файл-примера,кнопка use
[vba]
Код
Sub help() Dim t$, i&: t = Range("B2") With CreateObject("VBScript.RegExp"): .Pattern = "\d+(?= ШТ)": .Global = True For i = 0 To .Execute(t).Count - 1: Range("F2").Offset(, 2 * i - 2) = CStr(.Execute(t)(i)): Next End With End Sub
[/vba] [vba]
Код
Sub help1() Dim t$, i&: t = Range("B2") With CreateObject("VBScript.RegExp"): .Pattern = "(?:Артикул\: ).+?(?=;)": .Global = True For i = 0 To .Execute(t).Count - 1: Range("F2").Offset(, 2 * i - 3) = Mid(CStr(.Execute(t)(i)), 10): Next End With End Sub
[/vba]
Harry, еще вариант макроса для исходного(первого) файл-примера,кнопка use
[vba]
Код
Sub help() Dim t$, i&: t = Range("B2") With CreateObject("VBScript.RegExp"): .Pattern = "\d+(?= ШТ)": .Global = True For i = 0 To .Execute(t).Count - 1: Range("F2").Offset(, 2 * i - 2) = CStr(.Execute(t)(i)): Next End With End Sub
[/vba] [vba]
Код
Sub help1() Dim t$, i&: t = Range("B2") With CreateObject("VBScript.RegExp"): .Pattern = "(?:Артикул\: ).+?(?=;)": .Global = True For i = 0 To .Execute(t).Count - 1: Range("F2").Offset(, 2 * i - 3) = Mid(CStr(.Execute(t)(i)), 10): Next End With End Sub
Harry, добавил еще один цикл,кнопки в столбце O,,продлил,Ваш вариант файл-примера,первого на 10 строк,работает при наличии текста Артикул,второй файл - пример не смотрел пока.
Harry, добавил еще один цикл,кнопки в столбце O,,продлил,Ваш вариант файл-примера,первого на 10 строк,работает при наличии текста Артикул,второй файл - пример не смотрел пока.sv2014
sv2014, Да, все великолепно работает! В таком большом массиве данных не важно, если несколько строк будут без ключевого значения и часть значений потеряется.
А можно продлить макрос не на 10 строк, а на 1000 или 1500?))))
sv2014, Да, все великолепно работает! В таком большом массиве данных не важно, если несколько строк будут без ключевого значения и часть значений потеряется.
А можно продлить макрос не на 10 строк, а на 1000 или 1500?))))Harry
Harry, в макросе меняем 10 на произвольное значение типа:
[vba]
Код
Sub help3() Dim t$, j&, i& With CreateObject("VBScript.RegExp"): .Pattern = "\d+(?= ШТ)": .Global = True For j = 2 To Range("B" & Rows.Count).End(xlUp).Row t = Range("B" & j) For i = 0 To .Execute(t).Count - 1: Range("F" & j).Offset(, 2 * i - 2) = CStr(.Execute(t)(i)): Next Next End With End Sub
[/vba]
Harry, в макросе меняем 10 на произвольное значение типа:
[vba]
Код
Sub help3() Dim t$, j&, i& With CreateObject("VBScript.RegExp"): .Pattern = "\d+(?= ШТ)": .Global = True For j = 2 To Range("B" & Rows.Count).End(xlUp).Row t = Range("B" & j) For i = 0 To .Execute(t).Count - 1: Range("F" & j).Offset(, 2 * i - 2) = CStr(.Execute(t)(i)): Next Next End With End Sub
sv2014, я прошу прошения, но у меня возможности в этом вопросе ограниченны(((( Можно попросить такой же пример выложить как файл 9337336.xls с измененным кол-вом? 1000 вполне подойдет)))
sv2014, я прошу прошения, но у меня возможности в этом вопросе ограниченны(((( Можно попросить такой же пример выложить как файл 9337336.xls с измененным кол-вом? 1000 вполне подойдет)))Harry
Harry, Harry, добавил в #14 файл-пример,для любого количества строк,с проверкой наличия слова Артикул
[vba]
Код
Sub help5() Dim t$, i&, j& With CreateObject("VBScript.RegExp"): .Pattern = "(?:Артикул\: ).+?(?=;)": .Global = True For j = 2 To Range("B" & Rows.Count).End(xlUp).Row t = Range("B" & j) If .test(t) Then For i = 0 To .Execute(t).Count - 1 Range("F" & j).Offset(, 2 * i - 3) = Mid(CStr(.Execute(t)(i)), 10) Next End If Next End With End Sub
[/vba]
Harry, Harry, добавил в #14 файл-пример,для любого количества строк,с проверкой наличия слова Артикул
[vba]
Код
Sub help5() Dim t$, i&, j& With CreateObject("VBScript.RegExp"): .Pattern = "(?:Артикул\: ).+?(?=;)": .Global = True For j = 2 To Range("B" & Rows.Count).End(xlUp).Row t = Range("B" & j) If .test(t) Then For i = 0 To .Execute(t).Count - 1 Range("F" & j).Offset(, 2 * i - 3) = Mid(CStr(.Execute(t)(i)), 10) Next End If Next End With End Sub
Sub Harry1() Dim arr1() Application.ScreenUpdating = False For Each cl In Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row) If InStr(cl.Value, "Артикул") Then arr = Split(cl.Value, "Артикул: ") u = UBound(arr) * 2 ReDim arr1(1 To u) For x = 1 To UBound(arr) i = i + 1 arr1(i) = Left(arr(x), InStr(arr(x), ";") - 1) k = InStr(arr(x), "Кол-во:") + 8 k1 = InStr(arr(x), "ШТ") If k1 = 0 Then k1 = InStr(k, arr(x), ";") arr1(i + 1) = Mid(arr(x), k, k1 - k) i = i + 1 Next x cl.Offset(0, 1).Resize(1, UBound(arr1)).Value = arr1 ReDim arr1(0) Set arr = Nothing i = 0 End If Next Application.ScreenUpdating = True End Sub
[/vba]
еще вариант для "артикулов" [vba]
Код
Sub Harry1() Dim arr1() Application.ScreenUpdating = False For Each cl In Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row) If InStr(cl.Value, "Артикул") Then arr = Split(cl.Value, "Артикул: ") u = UBound(arr) * 2 ReDim arr1(1 To u) For x = 1 To UBound(arr) i = i + 1 arr1(i) = Left(arr(x), InStr(arr(x), ";") - 1) k = InStr(arr(x), "Кол-во:") + 8 k1 = InStr(arr(x), "ШТ") If k1 = 0 Then k1 = InStr(k, arr(x), ";") arr1(i + 1) = Mid(arr(x), k, k1 - k) i = i + 1 Next x cl.Offset(0, 1).Resize(1, UBound(arr1)).Value = arr1 ReDim arr1(0) Set arr = Nothing i = 0 End If Next Application.ScreenUpdating = True End Sub