Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 18.08.2023, 15:43   #1
olgomets
Новичок
Джуниор
 
Регистрация: 18.08.2023
Сообщений: 4
По умолчанию Удаление одинаковых строк

Про шерстил много подобных задач но везде ищут дубликаты и удаляют, оставляя при этом одну строку. Мне же в моей задаче нужно находить дубликаты (полностью идентичные строки в которых все значения во всех столбцах совпадают) и удалять и исходную строку и дублера. Оставив только уникальные строки у которых изначально во всем диапазоне не было дубликатов. Для примера приложу две таблицы исходную и желаемый результат.
Вложения
Тип файла: xlsx Исходная таблица.xlsx (10.0 Кб, 7 просмотров)
Тип файла: xlsx Желаемый результат.xlsx (9.3 Кб, 5 просмотров)
olgomets вне форума Ответить с цитированием
Старый 18.08.2023, 20:25   #2
Elixi
Форумчанин
 
Регистрация: 10.05.2019
Сообщений: 164
По умолчанию

Цитата:
Сообщение от olgomets Посмотреть сообщение
Мне же в моей задаче нужно находить дубликаты (полностью идентичные строки в которых все значения во всех столбцах совпадают) и удалять и исходную строку и дублера. Оставив только уникальные строки у которых изначально во всем диапазоне не было дубликатов. Для примера приложу две таблицы исходную и желаемый результат.
Так ваш пример не совпадает с тем что вы излагаете. Например обозначение 20-0000107 Шайба... в исходной таблице находится два раза, но строки не во всех столбцах полностью идентичные. Количество так в одном случае 59 во втором 53. И вы обе строки удалили. Так что тут что-то не совсем корректно. Либо задача, либо показанный желаемый результат. (20-0000105 Шайба - то же самое).
Elixi вне форума Ответить с цитированием
Старый 18.08.2023, 20:33   #3
olgomets
Новичок
Джуниор
 
Регистрация: 18.08.2023
Сообщений: 4
По умолчанию

Цитата:
Сообщение от Elixi Посмотреть сообщение
Так ваш пример не совпадает с тем что вы излагаете. Например обозначение 20-0000107 Шайба... в исходной таблице находится два раза, но строки не во всех столбцах полностью идентичные. Количество так в одном случае 59 во втором 53. И вы обе строки удалили. Так что тут что-то не совсем корректно. Либо задача, либо показанный желаемый результат. (20-0000105 Шайба - то же самое).
Виноват. Вы совершенно правы. Удалял вручную. Долго бился с этой проблемой и глаз замылился. Выкладываю исправленный файл с желаемым результатом.
Вложения
Тип файла: xlsx Желаемый результат_испр..xlsx (9.3 Кб, 4 просмотров)
olgomets вне форума Ответить с цитированием
Старый 18.08.2023, 22:53   #4
Elixi
Форумчанин
 
Регистрация: 10.05.2019
Сообщений: 164
По умолчанию

Код:
Sub olgomets_dubli()
'   https://programmersforum.ru/showthread.php?t=346178
' запускайте при активном листе исходной таблицы вашего файла
' макрос создает копию листа и вней удалит дубли
    Dim M(), Rw&, RwL&, Co&, CoL&, i&, Udalim As Boolean
    Dim RngToDel$, RwsToDel As Object
    Set RwsToDel = CreateObject("Scripting.Dictionary")
    
    RwL = Cells(Rows.Count, 1).End(xlUp).Row
    CoL = Cells(1, Columns.Count).End(xlToLeft).Column
    M = Range(Cells(1, 1), Cells(RwL, CoL))

    For Rw = LBound(M, 1) To UBound(M, 1) - 1
        For i = Rw + 1 To UBound(M, 1)
            If M(i, LBound(M, 2)) = M(Rw, LBound(M, 2)) Then
                For Co = 1 + LBound(M, 2) To UBound(M, 2)
                    If M(i, Co) = M(Rw, Co) Then
                        Udalim = True
                    Else
                        Udalim = False: Exit For
                    End If
                Next Co
                If Udalim Then
                    Udalim = False
                    If Not RwsToDel.Exists(Rw) Then
                        RwsToDel.Add Rw, Rw
                    End If
                    If Not RwsToDel.Exists(i) Then
                        RwsToDel.Add i, i
                    End If
                End If
            End If
        Next i
    Next Rw

    For i = 0 To RwsToDel.Count - 1
        RngToDel = RngToDel & RwsToDel.items()(i) & ":" _
                            & RwsToDel.items()(i) & ","
    Next i
    RngToDel = Mid(RngToDel, 1, Len(RngToDel) - 1)
    Set RwsToDel = Nothing
    
    Application.ScreenUpdating = False
        ActiveSheet.Copy Before:=ActiveSheet
        Range(RngToDel).Delete Shift:=xlUp
    Application.ScreenUpdating = True
    
End Sub
Elixi вне форума Ответить с цитированием
Старый 18.08.2023, 23:22   #5
olgomets
Новичок
Джуниор
 
Регистрация: 18.08.2023
Сообщений: 4
По умолчанию

Принято. Спасибо. Буду пробовать.
olgomets вне форума Ответить с цитированием
Старый 19.08.2023, 01:37   #6
Elixi
Форумчанин
 
Регистрация: 10.05.2019
Сообщений: 164
По умолчанию

olgomets, предыдущий макрос устраняет только ограниченное количество строк.
Следующий должен устранять не ограниченное.
Код:
Sub olgomets_dubli_v2()
'   https://programmersforum.ru/showthread.php?t=346178
' запускайте при активном листе исходной таблицы вашего файла
' макрос создает копию листа и вней удалит дубли
    Dim M(), Rw&, RwL&, Co&, CoL&, i&, Udalim As Boolean
    Dim RngToDel As Range, RwsToDel As Object
    Set RwsToDel = CreateObject("Scripting.Dictionary")
    
    ActiveSheet.Copy Before:=ActiveSheet
    RwL = Cells(Rows.Count, 1).End(xlUp).Row
    CoL = Cells(1, Columns.Count).End(xlToLeft).Column
    M = Range(Cells(1, 1), Cells(RwL, CoL))

    For Rw = LBound(M, 1) To UBound(M, 1) - 1
        For i = Rw + 1 To UBound(M, 1)
            If M(i, LBound(M, 2)) = M(Rw, LBound(M, 2)) Then
                For Co = 1 + LBound(M, 2) To UBound(M, 2)
                    If M(i, Co) = M(Rw, Co) Then
                        Udalim = True
                    Else
                        Udalim = False: Exit For
                    End If
                Next Co
                If Udalim Then
                    Udalim = False
                    If Not RwsToDel.Exists(Rw) Then
                        RwsToDel.Add Rw, Rw
                    End If
                    If Not RwsToDel.Exists(i) Then
                        RwsToDel.Add i, i
                    End If
                End If
            End If
        Next i
    Next Rw

    For i = 0 To RwsToDel.Count - 1
        If RngToDel Is Nothing Then
            Set RngToDel = Range(RwsToDel.items()(i) & ":" _
                            & RwsToDel.items()(i))
        Else
            Set RngToDel = Union(RngToDel, _
                            Range(RwsToDel.items()(i) & ":" _
                            & RwsToDel.items()(i)))
        End If
    Next i
    Set RwsToDel = Nothing
    If Not RngToDel Is Nothing Then RngToDel.Delete
    
End Sub
Elixi вне форума Ответить с цитированием
Старый 19.08.2023, 11:11   #7
сфинкс
Форумчанин
 
Аватар для сфинкс
 
Регистрация: 17.06.2012
Сообщений: 987
По умолчанию

Строки из многих ячеек контролируются вручную

=СЦЕПИТЬ(A5;B5;C5;D5;E5)

=ЕСЛИ(G5=G6;1;"")

Вдруг подобные задачи другим понадобятся

https://www.youtube.com/watch?v=I0QV2AZ5W5E
Случайные и Массивы https://programmersforum.ru/showthread.php?t=344371 Учим C# & basic & excel & python https://programmersforum.ru/showthre...=327446&page=5 ничего нерекомендую

Последний раз редактировалось сфинкс; 19.08.2023 в 11:25.
сфинкс вне форума Ответить с цитированием
Старый 21.08.2023, 14:55   #8
olgomets
Новичок
Джуниор
 
Регистрация: 18.08.2023
Сообщений: 4
По умолчанию

Elixi, Огромное спасибо все отлично работает так как задумывалось.
olgomets вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц

Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Удаление одинаковых строк на листе Excel 2003 vfv Microsoft Office Excel 26 21.11.2014 12:58
Удаление одинаковых строк на разных листах Nanashi Microsoft Office Excel 3 29.09.2014 16:45
Удаление одинаковых строк из массива Алексей_2012 Общие вопросы Delphi 10 14.05.2013 09:19
Поиск одинаковых строк и изменения и удаление NightDevil Microsoft Office Excel 8 14.04.2012 01:45
удаление одинаковых слов (С/С++) jewel Помощь студентам 1 12.12.2008 15:14