Страницы: 1
RSS
Удаление дублей строк и сцепка содержимого ячеек
 
Доброе время суток!

Задачка по преобразованию таблички в несколько тысяч строк.
В файле Пример показано, как может выглядеть исходная таблица (Лист1) и к какому виду нужно преобразовать (Лист2).
В исходной много строк с одинаковым содержимым, за исключением ячейки в крайнем правом столбце (№документа). Причём, количество повторов у разных строк различное. Нужно дубликаты строк удалить, одновременно заполнив правую ячейку новым содержимым - сцепив через "; " номера документов, указанных в задублированных строках.
 
aesp, можно так
Код
Sub csg()
Dim lr As Long, i As Long
Application.ScreenUpdating = False
lr = Cells(Rows.Count, "A").End(xlUp).Row
   For i = lr To 7 Step -1
      If Cells(i, 1) = Cells(i - 1, 1) And Cells(i, 2) = Cells(i - 1, 2) And Cells(i, 4) = Cells(i - 1, 4) Then
         Cells(i - 1, 8) = Cells(i - 1, 8) & ";" & Cells(i, 8)
         Rows(i).Delete
       End If
    Next
  Application.ScreenUpdating = True
End Sub
Изменено: casag - 22.08.2019 18:04:56
 
Уважаемый, casag, всё отлично работает. Благодарю!

Поясните только, пожалуйста, почему цикл "То 7", а также не понятен смысл условия:
Цитата
If Cells(i, 1) = Cells(i - 1, 1) And Cells(i, 2) = Cells(i - 1, 2) And Cells(i, 4) = Cells(i - 1, 4)
И ещё: извините, забыл в описании задачи указать, что повторяющиеся строки могут быть и несмежными (Пример2).
Изменено: aesp - 23.08.2019 13:39:46
 
Цель достигнута!)
Нашёл решение здесь:
в "Копилке идей"
 
aesp, Добрый день . Ответы на ваши вопросы  читайте в коде макроса.
 
casag, огромное спасибо! Вы мне всё разъяснили!
Однако, несмежные одинаковые строки не обрабатывает.
Изменено: aesp - 23.08.2019 13:46:11
 
aesp,  в примере отрабатывает.Покажите пример файла в котором макрос не отработал несмежные.
 
Цитата
casag написал:
не отработал несмежные.
casag, сорри! Всё отлично) Тема закрыта)
Страницы: 1
Наверх