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

[Hugo121]

Да, запятые упустил...
Эту строку измените так:

            If .exists(t) Then
                If Len(b(i, 1)) Then b(.Item(t), 1) = b(.Item(t), 1) & ", " & b(i, 1): b(i, 1) = Empty
            Else

6 минут тоже немало - вероятно там много примечаний собирается?

[Скрипт]

Без использования команды Find и Dictionary. Но я читал на Форумах, что самый быстрый способ работы с отслеживанием одинаковых данных - это использование Dictionary. Поэтому код ниже не должен по идее быстрее работать кода, предложенного участником форума Hugo121:

Sub Procedure_1()

    'Указываем строку, с которой начинаются данные.
    Const myFirstRow As Long = 7
    
    Dim myArray_1() As Variant, myArray_2() As Variant
    Dim myEnd As Long
    Dim myUbound As Long
    Dim i As Long, j As Long
    
    '1. Узнаём номер строки с последним "ФИО".
    myEnd = Cells(Rows.Count, "C").End(xlUp).Row
    
    '2. Берём данные в массивы, т.к. с массивами код быстрее
    'работает, чем с объектами. Ячейки в Excel являются объектами.
    myArray_1() = Range("C" & myFirstRow & ":C" & myEnd)
    myArray_2() = Range("I" & myFirstRow & ":I" & myEnd)
    
    '3. Узнаём количество строк в массиве.
    'Чтобы в коде каждый раз это не делать - может быстрее будет.
    myUbound = UBound(myArray_1, 1)
    
    '4. Двигаемся по массиву "myArray_1".
    For i = 1 To myUbound - 1 Step 1
    
        'Если пусто.
        'Код удаляет повторяющиеся "ФИО" из массива.
        If IsEmpty(myArray_1(i, 1)) = True Then
            'Переход к следуещему "ФИО".
            GoTo metka
        End If
        
        '4.1. Просматриваем тот же самый массив "myArray_1", но
        'не с начала, а относительно очередного элемента.
        For j = i + 1 To myUbound Step 1
        
            If myArray_1(i, 1) = myArray_1(j, 1) Then
                '4.1.1. Удаляем из массива "ФИО". Пустой элемент
                'в массиве будет пропускаться.
                myArray_1(j, 1) = Empty
                '4.1.2. В массив "myArray_2" дописываем замечание.
                'Удаляем данные и из массива "myArray_2".
                If IsEmpty(myArray_2(j, 1)) = False Then
                
                    If IsEmpty(myArray_2(i, 1)) = False Then
                        myArray_2(i, 1) = myArray_2(i, 1) & "; " & myArray_2(j, 1)
                    Else
                        myArray_2(i, 1) = myArray_2(j, 1)
                    End If
                    
                    myArray_2(j, 1) = Empty
                    
                End If
                
            End If
            
        Next j
metka:

    Next i
    
    '5. Выводим изменённый массив на лист.
    Range("I" & myFirstRow & ":I" & myEnd).Value = myArray_2()
    
    'Сообщение, что работа кода завершена.
    MsgBox "Работа кода завершена!", vbInformation
    
End Sub

[Скрипт]

А если в сообщении #6 вот эту строку заменить, намного быстрее будет?

            '3.3.10. Ищем следующее вхождение.
            Set rFound = rSearch.FindNext(rFound)

С командой Find нужно быть осторожнее, т.к. она связана с диалоговым окном Найти и заменить. Поэтому в коде нужно сделать так, чтобы настройки диалогового окна Найти и заменить не повлияли на поиск в VBA.

[VictorM]

6 минут тоже немало - вероятно там много примечаний собирается?

Из 15000 строк набирается около 10000 уникальных, остальные - повторы от 2-х до 18-ти. Получается, что нужно собрать 5000 примечаний.

[Hugo121]

Ну ясно.
На всякий случай, проверьте особенно длинные примечания, не обрезано ли что.
Вообще я как-то подобное делал - там кажется были неожиданности, если примечание начиналось с цифры, особенно с отрицательной. Лучше поставить в начале апостроф.

[VictorM]

Hugo121, здравствуйте.
Все никак не сообщу Вам, что предложенный Вами код работает на 15 000 строк не более 2 сек!
То время, которое указывалось ранне - ошибочно.
Это было связано с соседним листом, на котором вся таблица пересчитывалась формулами уже после окончания работы кода.
Так что, прошу меня извинить, что ввел Вас в заблуждение.
А теперь вот, пробую немного модернизировать Ваш код, оказалось, что к заметкам нужно присоединять дату из столбца А.
Вроде получается, но она загвоздочка.
Если первая строка в повторяющихся была пустая, то в суммарной строке пишется дата.
вот так я сейчас изменил Ваш код

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

а дальше знаний не хватает.
Подскажите, пожалуйста, что нужно еще здесь изменить?
Спасибо.

[VictorM]

Получилось справиться с задачей модернизацией кода от Скрипт.
Изменил вот здесь

'3.3.7. Формируем текст для ячейки в столбце "Заметки".
        If IsEmpty(Cells(i, "I")) = False Then
            '            myNotes = CStr(Cells(i, "I").Value) & "; "
            myNotes = CStr(Cells(i, "A").Value) & " - " & (Cells(i, "I").Value) & "; "
        End If

но работает ОЧЕНЬ долго(

[Скрипт]

VictorM, в сообщении #12 есть ещё код.

[Hugo121]

Вроде бы так (добавил одну строку):

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

[VictorM]

Hugo121 спасибо, но не то.
Работает практически как и мой вариант изменений, да еще и добавляет теперь дату к примечаниям, если даже небыло повторов фамилии. Буду пробовать дальше.
Скрипт, да, этот вариант кода работает на порядок быстрее первого, вот сейчас тоже пытаюсь прикрутить к нему такое же (сцепку даты и заметки)