Повторы в столбце - собрать значения.

[VictorM]

Здравствуйте, Уважаемые!
Возник вопрос, с которым не могу справиться. Нужна Ваша помощь.
Есть таблица, 10 столбцов и пока 15000 строк.
В столбце ФИО данные могут повторяться 2 и более раз.
И есть столбец Заметки. В нем могут быть какие-то значения или он может быть пустым.
А задача у меня такая - нужно собрать все заметки, если ФИО повторяется, в первую строку с этой фамилией.
Я сделал пример (повторы подсвечены цветом) того, что нужно получить, причем гланое - собрать все в первую строку, а в поторяющихся строках уже не важно. Можно удалить, можно оставить как есть или же заполнить собранными значениями все строки с этой фамилией.
Подскажите, пожалуйста, как все это можно сделать?
Спасибо.
з.ы. Как это будет сделано, формулами или макросом - не принципиально.
Работа будет делаться 1-2 раза в месяц.

[strannick]

А может сначала отобрать уникальные, а под них уже сделать выборку из Заметок?

[Hugo121]

Кстати, про рыбу :
Вообще-то есть уже такая UDF - VLOOKUPCOUPLE() http://62.76.186.34/forum.php?thread_id=45721
или СЦЕПИТЬЕСЛИ()
Только для неё нужен персональный допстолбец.
Как оказалось с VLOOKUPCOUPLE() - не внутри проверяемого диапазона! (СЦЕПИТЬЕСЛИ() не проверял)

[VictorM]

Кстати, про рыбу :

да, да!
я не прошу сделать за меня, я просто не могу понять, как к этому подступиться.
Поэтому прошу совета.

А может сначала отобрать уникальные, а под них уже сделать выборку из Заметок?

была и такая мысль, и СЦЕПИТЬЕСЛИ().

Только для неё нужен персональный допстолбец.

не проблема, подойдут любые варианты решения.
Спасибо за ответы и ссылку, буду пробовать.

[VictorM]

Сработал комбинированный вариант:
Столбец с уникальными + столбец СЦЕПИТЬЕСЛИ().
Большое спасибо за подсказку!
Отдельное спасибо Дмитрию/The_Prist за его функцию!

[Скрипт]

VictorM, я так и не понял, в чём сложность задачи, если вам и макросами подойдёт: найти похожее, куда-то что-то поместить.

Sub Procedure_1()

    'Указываем строку, с которой начинаются данные.
    Const myFirstRow As Long = 7
    
    Dim rSearch As Excel.Range
    Dim rFound As Excel.Range, myAddress As String
    Dim myDone() As String
    Dim myFIO As String
    Dim myEnd As Long
    Dim myNotes As String
    Dim myFlag As Boolean
    Dim i As Long, j As Long
    
    '1. Подготавливаем массив "myDone" к использованию.
    ReDim myDone(1 To 1)
    
    '2. Узнаём номер строки с последним "ФИО".
    myEnd = Cells(Rows.Count, "C").End(xlUp).Row
    
    '3. Двигаемся по столбцу "C".
    '"-1", т.к. у последнего ФИО нет смысла искать повторы.
    For i = myFirstRow To myEnd - 1 Step 1
        
        '3.1. Быстрее работать с переменными, чем с объектами.
        'Поэтому помещаем данные из ячейки в переменную.
        myFIO = CStr(Cells(i, "C").Value)
        
        '3.2. Смотрим, не анализировалось ли уже данное ФИО.
        If UBound(myDone) > 1 Then
            For j = 1 To UBound(myDone) - 1 Step 1
                If myFIO = myDone(j) Then
                    myFlag = True
                    Exit For
                End If
            Next j
            If myFlag = True Then
                'Подготавливаем переменную "myFlag" к следующему использованию.
                myFlag = False
                'Переходим к следущей ФИО в столбце "C".
                GoTo metka
            End If
        End If
        
        '3.3. Ищем повторы.
        
        '3.3.1. Задаём диапазон поиска.
        Set rSearch = Range("C" & i + 1 & ":C" & myEnd)
        
        '3.3.2. Осуществляем поиск.
        'After:=Range("C" & myEnd) - т.к. поиск ведётся после указанной ячейки.
        Set rFound = rSearch.Find(What:=myFIO, After:=Range("C" & myEnd), _
            LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, _
            SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        
        '3.3.3. Смотрим результат поиска.
        If rFound Is Nothing Then
            'Переходим к следующему "ФИО".
            GoTo metka
        End If
        
        '3.3.4. Записываем "ФИО" в массив "myDone", чтобы знать,
        'что это "ФИО" уже проанализировано.
        myDone(UBound(myDone)) = myFIO
        
        '3.3.5. Добавляем в массива "myDone" строку для следующего "ФИО".
        ReDim Preserve myDone(1 To UBound(myDone) + 1)
        
        '3.3.6. Запоминаем адрес ячейки, чтобы остановить затем поиск.
        myAddress = rFound.Address
        
        '3.3.7. Формируем текст для ячейки в столбце "Заметки".
        If IsEmpty(Cells(i, "I")) = False Then
            myNotes = CStr(Cells(i, "I").Value) & "; "
        End If
        
        'Продолжаем поиск с помощью "Do ... Loop".
        Do
        
            If IsEmpty(rFound.Offset(0, 6)) = False Then
                
                '3.3.8. Формируем текст для ячейки в столбце "Заметки".
                myNotes = myNotes & CStr(rFound.Offset(0, 6).Value) & "; "
                
                '3.3.9. Удаляем заметки из найденной ячейки.
                'Я использую "Formula", т.к. это работает во всех случаях,
                'в т.ч. и в этом.
                rFound.Offset(0, 6).Formula = ""
            
            End If
            
            '3.3.10. Ищем следующее вхождение.
            'After:=rFound - поиск идёт после найденной ячейки.
            Set rFound = rSearch.Find(What:=myFIO, After:=rFound, _
                LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, _
                SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            
        Loop While rFound.Address <> myAddress
        
        If myNotes <> "" Then
            '3.3.11. Корректируем переменную: удаляем в конце "; ".
            myNotes = Left(myNotes, Len(myNotes) - 2)
            '3.3.12. Помещаем "Заметки".
            Cells(i, "I").Value = myNotes
            '3.3.13. Подготавливаем переменную "myNotes" к следующему использованию.
            myNotes = ""
        End If
        
metka:
    Next i
    
    'Сообщение, что работа кода завершена.
    MsgBox "Работа кода завершена!", vbInformation
    
End Sub

Примечание

1. Чтобы код быстрее работал, отключите на время работы кода (с помощью кода):
   1. обновление монитора;
   2. запуск событий;
   3. пересчёт формул.
   После выполнения кода - снова включите.
   
2. Команда Find ищет текст не более 255 символов.

[VictorM]

Скрипт, спасибо за код!
Работает отлично, и избавляет от доп.столбцов.
А сложность в том, что я просто не мог понять, с какого края подойти к этой задаче.
А может сказались праздники и сопутствующая усталость
Еще раз СПАСИБО!

[Hugo121]

Ну если делать макросом, то можно попроще (извините, без комментов):

Sub tt()
    Dim a, b, i&, t$
    a = [c5].CurrentRegion.Columns(3).Value
    b = [c5].CurrentRegion.Columns(9).Value
    With CreateObject("scripting.dictionary")
        For i = 3 To UBound(a)
            t = a(i, 1)
            If .exists(t) Then
                b(.Item(t), 1) = b(.Item(t), 1) & ", " & b(i, 1): b(i, 1) = Empty
            Else
                .Item(t) = i
            End If
        Next
    End With
    [c5].CurrentRegion.Columns(9).Value = b
End Sub

[VictorM]

извините, без комментов

Супер! Спасибо!
а с коментами уж разберусь

[VictorM]

на реальном файле в 15000 строк с
ScreenUpdating = False и Calculation = xlManual
код от Скрипт отработал за 13 мин
код Hugo121 - за 6 мин.
6 мин меня вполне устраивает, делаться это будет нечасто, подожду
Отличие еще есть в том, что код Скрипт оставляет результирующие ячейки пустыми, если небыло вообще примечание ни в одном повторении фамилии (что, собственное, желательно), а код Hugo121 ставит запятые.
Но с этим я постараюсь разобраться.
Спасибо всем за помощь!