Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Извлечение части текста из строк с переносом извлеченых фрагментов в другой столбец и формированием из них уникального списка
 
#1
09.10.2019 10:09:05
Добрый день форумчане,

Нужно извлечь часть текста из строк в диапазоне A2:A24 с переносом извлеченых фрагментов в другой столбец и формированием из них уникального списка.
При этом нужно учесть объем тары из диапазона B2:B24 для каждого наименования.
Одинаковые наименования объединять для тары 1 L, тоже самое делать и для объема 250 МL и 650 GR
Не знаю насколько это возможно сделать формулами?
 
 
 
#2
09.10.2019 10:51:48
Код
Sub aaaaa()
Dim DC As Object, a&, arr(), dd(), aa$, dt$
Set DC = CreateObject("Scripting.Dictionary")
With ActiveSheet
  a = .Cells(.Rows.Count, "A").End(xlUp).Row
  arr = .Range("A2:B" & a).Value
  For a = 1 To UBound(arr)
    aa = Split(arr(a, 1), "/")(0)
    If InStr(aa, "100% ORGANIC") Then
      dt = Mid(aa, InStr(InStr(InStr(1, aa, " ") + 1, aa, " ") + 1, aa, " ") + 1)
    Else: dt = aa
    End If
    DC.Item(dt & "*" & arr(a, 2)) = arr(a, 2)
  Next: ReDim arr(1 To DC.Count, 1 To 2): dd = DC.keys()
  For a = 1 To DC.Count
    arr(a, 1) = Split(dd(a - 1), "*")(0): arr(a, 2) = Split(dd(a - 1), "*")(1)
  Next
  .[H2].Resize(DC.Count, 2) = arr
End With
End Sub
 
 
 
#3
09.10.2019 10:57:03
memo,
Признаться честно мне не до конца понятен принцип, по которому Вы формируете свой список:

Как должно быть представляет собой текст, который вырезается из оригинального текста между третьим пробелом и первым слешем; а если хотя бы один из признаков отсутствует, то сохраняется оригинальный текст целиком? Правильно?

Почему CARROT JUICE потерял начало ORANGE, а в другом случае YELLOW?
Тот же вопрос о NECTARINE JUICE: куда пропал PINK?
и за что SOUR CHERRY JUICE лишился TART?

Пожалуйста, уточните критерий формирования текста.
 
 
 
#4
09.10.2019 11:24:55
IKor, Вы правы, мне следовало упомянуть эти ньюансы.
Нужны только названия соков, без Orange, Pink, Organic, Pure, / NFC и т.д.
Orange и Pink в данном случае тоже не должны присутствовать, но это скорее исключение из правил, потому что они все-таки часть названий.
Вот перечень исключений:
TART
ORANGE
PINK
YELLOW


Anchoret,
Спасибо большое. А можно модифицировать код таким образом, чтобы он работал в тех же столбцах?  (пример переделал)
И можно ли сделать нечто подобное формулами?
Изменено: memo - 09.10.2019 11:41:31
 
 
 
#5
09.10.2019 11:41:05
Формулами может и можно, но это не ко мне) Выгрузка туда-же, откуда взяли данные. Если нужно ниже , то в конце кода измените адрес выгрузки и закомментируйте ".ClearContents"
Код
Sub aaaaa()
Dim DC As Object, a&, arr(), dd(), aa$, dt$
Set DC = CreateObject("Scripting.Dictionary")
With ActiveSheet
  a = .Cells(.Rows.Count, "B").End(xlUp).Row
  With .Range("B4:C" & a)
    arr = .Value: .ClearContents
  End With
  For a = 1 To UBound(arr)
    If Len(arr(a, 1)) > 0 Then
      aa = Split(arr(a, 1), "/")(0)
      If InStr(aa, "100% ORGANIC") Then
        dt = Mid(aa, InStr(InStr(InStr(1, aa, " ") + 1, aa, " ") + 1, aa, " ") + 1)
      Else: dt = aa
      End If
      DC.Item(dt & "*" & arr(a, 2)) = arr(a, 2)
    End If
  Next: ReDim arr(1 To DC.Count, 1 To 2): dd = DC.keys()
  For a = 1 To DC.Count
    arr(a, 1) = Split(dd(a - 1), "*")(0): arr(a, 2) = Split(dd(a - 1), "*")(1)
  Next
  .[B4].Resize(DC.Count, 2) = arr
End With
End Sub
Изменено: Anchoret - 09.10.2019 11:43:13
 
 
 
#6
09.10.2019 11:53:37
Цитата
Anchoret написал:
закомментируйте ".ClearContents"
Что-то не выходит у меня.
 
 
 
#7
09.10.2019 12:03:25
Т.к. данные (если они будут друг над другом: оригинал и итоговый список), то в начале нужно указывать жесткий диапазон при взятии диапазона с листа в массив. Иначе получится ерунда и макрос заберет в массив все данные по двум столбцам по последнюю заполенную ячейку "В" включительно со всеми вытекающими.

П.С.: чтобы закомментировать кусок кода нужно перед ним поставить одинарную кавычку.
 
 
 
#8
09.10.2019 12:19:59
Так, кажется почти получается. Указал диапазон "B4:C26"
Внизу адрес выгрузки изменил на B44, все работает, но захватывает текст "КАК ДОЛЖНО БЫТЬ" из ячейки B43
 
 
 
#9
09.10.2019 12:25:12
...
Код
Sub aaaaa()
Dim DC As Object, a&, arr(), dd(), aa$, dt$
Set DC = CreateObject("Scripting.Dictionary")
With ActiveSheet
  arr = .Range("B4:C42").Value
  For a = 1 To UBound(arr)
    If Len(arr(a, 1)) > 0 Then
      aa = Split(arr(a, 1), "/")(0)
      If InStr(aa, "100% ORGANIC") Then
        dt = Mid(aa, InStr(InStr(InStr(1, aa, " ") + 1, aa, " ") + 1, aa, " ") + 1)
      Else: dt = aa
      End If
      DC.Item(dt & "*" & arr(a, 2)) = arr(a, 2)
    End If
  Next: ReDim arr(1 To DC.Count, 1 To 2): dd = DC.keys()
  For a = 1 To DC.Count
    arr(a, 1) = Split(dd(a - 1), "*")(0): arr(a, 2) = Split(dd(a - 1), "*")(1)
  Next
  .[B44].Resize(DC.Count * 2, 2).ClearContents
  .[B44].Resize(DC.Count, 2) = arr
End With
End Sub
 
 
 
#10
09.10.2019 12:33:03
Anchoret,
Все ОК, спасибо.
Буду признателен, если кто-нибудь предложит вариант формулами.  
 
 
 
Страницы: 1
Наверх