Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Макрос разделения текста по столбцам с перемещением данных в один столбец
 
Привет!
Помогите, пожалуйста, с макросом. Есть файл (см.вложение) в котором имейлы в одной ячейке отделены разделителем ; и пробелом
Нужно, чтобы после отработки макроса открывался новый лист эксель в котором имейлы указывались друг под другом в одном солбце без разделителей. Рядом соответствующая Группа, к которой он принадлежал (как в файле на примере "Вид данных после отработки макросом"). Если возможно, то, чтобы также происходила сортировка по Группам в порядке возрастания.
Буду очень благодарен за помощь!
 
vladok05, только макросом? просто просто можно сделать в PQ одной кнопкой буквально
Изменено: Mershik - 22 май 2020 19:17:17
 
Вот, смотрите, пробуйте.
Код
Sub vvvw()
    Dim tempArr, i As Integer, j As Integer, LastRow As Integer, NextRow As Integer
    LastRow = Worksheets("Лист1").Cells(Rows.Count, 2).End(xlUp).Row
    Worksheets.Add after:=Worksheets("Лист1"): Worksheets("Лист1").Activate
        For i = 3 To LastRow
            Cells(i, 2) = Replace(Cells(i, 2), " ", "")
            tempArr = Split(Cells(i, 2), ";")
            For j = 0 To UBound(tempArr)
                    Worksheets(2).Range("A1:B1") = Array("Группы", "Адреса")
                    NextRow = Worksheets(2).Cells(Rows.Count, 2).End(xlUp).Row + 1
                    Worksheets(2).Cells(NextRow, 2) = tempArr(j)
                    Worksheets(2).Cells(NextRow, 1) = Worksheets(1).Cells(i, 1)
            Next j
        Next i
    With Worksheets(2).Range("A1").CurrentRegion
        .Borders.LineStyle = xlContinuous
        .Sort Key1:=Worksheets(2).Range("A1"), Order1:=xlAscending, Header:=xlYes
    End With
End Sub

Изменено: DANIKOLA - 22 май 2020 19:49:45
 
Цитата
как в файле на примере "Вид данных после отработки макросом
Код
Sub Email()
Dim arr
Dim i As Long
Dim iLastRow As Long
Dim n As Integer
Dim k As Integer
   iLastRow = Range("A2").End(xlDown).Row
   k = 9
  For i = 3 To iLastRow
    arr = Split(Cells(i, "B"), ";")
    For n = 0 To UBound(arr)
      Cells(i + k + n, "A") = Cells(i, "A")
      Cells(i + k + n, "B") = arr(n)
    Next
    k = k + n - 1
  Next
End Sub
 
Круто! Спасибо большое! Могу еще чуть понаглеть и усложнить вопрос? только сообразил   :)
Есть еще столбец Критерий. Нужно, чтобы после отработки макроса выводило результаты только с данными, которые соответствуют "Критерию 2" (как во вложении в "Вид данных после отработки макросом").
В столбце "Группы" тоже могут быть перечислены несколько групп с разделителем ; которые тоже нужно преобразовать в столбец, по аналогии с имейлами (см. "Вид данных после отработки макросом"). Должны перечисляться группы и соответствующие им имейлы.
Выводить результат лучше в новой книге, а не в новом листе.

Идеально было бы, если бы при запуске макроса в диалоговом окне можно было выбрать по каким группам нужно вывести отчет (множественный выбор) и в новой книге выводится только список имейлов в столбец (можно без групп). Повторяющиеся имейлы удалены. Это все только по Критерию 2. Критерий 1 игнорируется, данные по нему не обрабатываются.

Буду очень благодарен!
 
vladok05, а зачем Вы процитировали код? Полагаете, что Кузьмич забыл его?  
 
vladok05, выкладываешься на все сто, а тут, ой, а еще бы это добавить. Не очень приятно. Кстати вы цитировали не мой код, а Kuzmichа. У меня нету в коде Cells(i, "B")
 
Простите, пожалуйста, сегодня первый день на ресурсе, не правильно использовал кнопку цитировать  :(
И прошу прощение, что не сразу дал все вводные, писал в спешке, потому что срочно этот макрос нужен(
Буду благодарен, если поможете!
 
Цитата
выводило результаты только с данными, которые соответствуют "Критерию 2"
Код
Sub Email_Group_Kriteria2()
Dim FoundCell As Range
Dim FAdr As String
Dim arrGroup
Dim arrEmail
Dim i As Long
Dim n As Integer
Dim k As Integer
   k = 12
    Set FoundCell = Columns("A").Find("Критерий 2", , xlValues, xlWhole)
    If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address
      Do
        arrGroup = Split(Cells(FoundCell.Row, "B"), ";")
        For i = 0 To UBound(arrGroup)
         arrEmail = Split(Cells(FoundCell.Row, "C"), ";")
          For n = 0 To UBound(arrEmail)
            Cells(k + n, "A") = arrGroup(i)
            Cells(k + n, "B") = arrEmail(n)
          Next
           k = k + n
        Next
        Set FoundCell = Columns("A").FindNext(FoundCell)
      Loop While FoundCell.Address <> FAdr
    End If
End Sub

В другую книгу переделайте сами. Удачи!
 
В PQ наклацал
Код
let
    Источник = Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content],
    #"Измененный тип" = Table.TransformColumnTypes(Источник,{{"Критерий", type text}, {"Группы", type text}, {"Адреса", type text}}),
    #"Строки с примененным фильтром" = Table.SelectRows(#"Измененный тип", each ([Критерий] = "Критерий 2")),
    #"Разделить столбец по разделителю" = Table.ExpandListColumn(Table.TransformColumns(#"Строки с примененным фильтром", {{"Группы", Splitter.SplitTextByDelimiter("; ", QuoteStyle.None), let itemType = (type nullable text) meta [Serialized.Text = true] in type {itemType}}}), "Группы"),
    #"Разделить столбец по разделителю1" = Table.ExpandListColumn(Table.TransformColumns(#"Разделить столбец по разделителю", {{"Адреса", Splitter.SplitTextByDelimiter("; ", QuoteStyle.None), let itemType = (type nullable text) meta [Serialized.Text = true] in type {itemType}}}), "Адреса"),
    #"Удаленные столбцы" = Table.RemoveColumns(#"Разделить столбец по разделителю1",{"Критерий"})
in
    #"Удаленные столбцы"
 
Цитата
quasarrr написал:
наклацал
То же самое, редактируя
Код
// Таблица1
let
    Источник = Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content],
    Custom = let a=Table.SelectRows(Источник, each ([Критерий] = "Критерий 2")),
    b={"Группы","Адреса"},c=List.Accumulate(b,a,(a,b)=> let i=Table.TransformColumns
    (a,{{b,each Text.Split(_,"; ")}}) in Table.ExpandListColumn(i,b)) in Table.SelectColumns(c,b)
in
    Custom
 
Спасибо большое за помощь!
Страницы: 1
Читают тему (гостей: 1)
Наверх