Страницы: 1
RSS
Получить сгруппированный список по общему значению
 
Прошу сильно не бить, сам недавно узнал как макросы делаются. Ничего похожего, к сожалению, не нашел. Вполне вероятно, что неправильно задаю вопрос для поисковых систем. Надеюсь, что уважаемые форумчане мне помогут.

Есть таблица вида:
Яблоки Петя
Груши Петя
Апельсины Петя
Яблоки Вася
Груши Катя
Апельсины Вася

Как в макросе сформировать (переменную) что бы получать вывод типа:
Петя (переменная) = Яблоки, Груши, Апельсины
Вася (переменная) = Яблоки, Апельсины
Катя (переменная) = Груши
 
Вы лучше простыми словами опишите, что вы хотите получить в итоге - например, "хочу получить сгруппированный список сухофруктов от имени одноклассников" - или как-то наподобие. А мы постараемся предложить решение.
Вообще офигенно будет если приложите файл с примером данных (как есть) и примером желательного результата (как надо). Небольшой по объему.
Кому решение нужно - тот пример и рисует.
 
Цитата
Пытливый написал: Вообще офигенно будет если...
если я угадал, что нужно  :)  
 
Цитата
_Igor_61 написал:
если я угадал, что нужно    
Почти! У меня сейчас заполнение шаблона ворда переменными из экселя. Когда Катя ест только груши, получается одно письмо из серии "Нужно отметить заслуги поедания Катей груш". Но когда по Пете получается 3 письма по каждым фруктам - как-то странно. Хочется что бы так же формировалось одно письмо, а не три.
 
В примере Игоря сделайте заголовок в ячейке В1 - Имя
и запустите макрос в стандартном модуле
Код
Sub Name_Fruct()
Dim i As Long
Dim iLastRow As Long
Dim FoundCell As Range
Dim FAdr As String
   Range("D1") = Range("B1")
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  Range("D2:E" & iLastRow).ClearContents
   Range("B1:B" & iLastRow).AdvancedFilter xlFilterCopy, CopyToRange:=Range("D1"), Unique:=True
    iLastRow = Cells(Rows.Count, "D").End(xlUp).Row
  For i = 2 To iLastRow
    Set FoundCell = Columns(2).Find(Cells(i, 4), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
      FAdr = FoundCell.Address
      Do
       Cells(i, 5) = Cells(i, 5) & Cells(FoundCell.Row, 1) & ", "
        Set FoundCell = Columns(2).FindNext(FoundCell)
      Loop While FoundCell.Address <> FAdr
     End If
  Next
End Sub
 
Большое спасибо! Это очень похоже на правду! В понедельник проверю на рабочем файле.
Изменено: DimDimich - 13.01.2018 18:51:50
 
Цитата
DimDimich написал:
Почти! У меня сейчас заполнение шаблона ворда переменными из экселя.
А где что-то про ворд говорилось? Или я что-то пропустил?
Очень порадовало:
Цитата
DimDimich написал:
Почти!
Почти угадали! DimDimich,  Вам нужно решение Вашей задачи или на форуме сами должны догадаться, что Вам нужно?  (Это о файле с примером) и вообще об этомhttp://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=1&TID=45586&TITLE_SEO=45586-pravila-foruma
 
Цитата
_Igor_61 написал:
где что-то про ворд говорилось
Только в моём втором сообщении. Честно говоря считал это избыточной информацией.

Цитата
_Igor_61 написал:
Вам нужно решение Вашей задачи или
Конечно разжевать за меня, положить в рот и проглотить - звучит очень заманчиво. Но хотелось бы ещё и самому хотя бы немного подумать. По этому и описал в кратце ситуацию. Если уж совсем будет туго, тогда буду выкладывать реальные файлы.
Изменено: DimDimich - 14.01.2018 19:01:37
 
Что-то не хватает моего прошлого из детства по программированию. Прикладываю живые файлы. К сожалению, так и не смог приспособить к записи список в переменную для передачи в ворд.

Буду признателен, если поможете выполнить запись строки в теле письма "Изменения в учредительные документы не вносились.", если из екселя берется ОАО, ООО, ЗАО и тп.
Изменено: DimDimich - 15.01.2018 12:50:14
 
Господа хорошие, выручайте! Не уж-то мой запрос поверг в ступор интернет сообщество?
 
Цитата
DimDimich написал:
поверг в ступор
На основании чего был сделан такой вывод? Полагаю, просто неинтересно вникать в решение постоянно меняющейся задачи.
 
Цитата
Андрей VG написал:
Полагаю, просто неинтересно вникать в решение постоянно меняющейся задачи.
Прошу прощения, если сложилось именно такое впечатление.  Как я уже говорил ранее, не хотел озадачивать полной задачей. Но, к моему глубочайшему сожалению, собственных знаний не хватает для решения поставленной задачи.
 
Решил этот и другие свои вопросы, может не так изящно, как хотелось. Но тем не менее работает. Надеюсь кому-то поможет. Я решил делать в 2 приёма: сначала на дополнительный лист переносится что мне надо, а потом вносится в шаблон.
Код
Sub UniqueAgents()
'
Dim Delimeter As String, i As Long
    Delimeter = ", " 'символы-разделители (можно заменить на пробел или ; и т.д.)
      
    Sheets("Лист1").Select
    Columns("C:C").Select
    Selection.Copy
    Sheets("Лист2").Select
    Columns("A:A").Select
    ActiveSheet.Paste
    Rows("1:1").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Columns("A:A").Select
    ActiveSheet.Range("A:A").RemoveDuplicates Columns:=1, Header:=xlNo
    Range("A1").Select
    
    
  i = 1
  
    Do While Not IsEmpty(Cells(i, 1))
            r = 1
            'создаём и копируем переменные
            Dog = "" 'номер договора
            SData = "" 'дата начала
            EData = "" 'дата окончания
            Kurator = "" 'куратор
            DKurator = "" 'должность куратора
            Many = "0" 'собрано
            Izmena = ""
        Do While Not IsEmpty(Sheets("Лист1").Cells(r, 3))
                If Sheets("Лист2").Cells(i, 1) = Sheets("Лист1").Cells(r, 3) Then
        
        Dog = Dog & Sheets("Лист1").Cells(r, 1).Value & Delimeter
        SData = Sheets("Лист1").Cells(r, 7).Value
        EData = Sheets("Лист1").Cells(r, 8).Value
        Kurator = Sheets("Лист1").Cells(r, 15).Value
        DKurator = Sheets("Лист1").Cells(r, 16).Value
        Many = Many + Sheets("Лист1").Cells(r, 21).Value
        If Sheets("Лист1").Cells(r, 18).Text Like "*ФЗ*" Then Izmena = "" Else: Izmena = "Изменения в учредительные документы не вносились."
                    r = r + 1
                Else: r = r + 1
                End If
            Loop
            'вставляем переменные
        Cells(i, 2) = Left(Dog, Len(Dog) - Len(Delimeter))
        Cells(i, 3) = SData
        Cells(i, 4) = EData
        Cells(i, 5) = DKurator
        Cells(i, 6) = Kurator
        Cells(i, 7) = Izmena
        Cells(i, 8) = Many
        i = i + 1
    Loop
End Sub


В word шаблоне добавил окно для вставки переменной и туда уже добавлял из 7й ячейки 2го листа.
Изменено: DimDimich - 18.01.2018 16:35:46
Страницы: 1
Наверх