Удаление дубликатов строк из диапазона, состоящего из 18-ти колонок

@serviktor · Регистрация: 03.04.2018

Author24 — интернет-сервис помощи студентам

Доброго времени суток всем!
Имеется книга Excel с одним листом
На данном листе находится таблица, состоящая из 18-ти колонок и нескольких тысяч строк (в файле оставлю только малую часть, чтобы показать, о чем я говорю).
В файле имеется огромное множество дубликатов, нужно их удалить.
Имеется два варианта, оба из которых не работают. Задумка такая:
1-й вариант: перебираю в цикле i каждый из столбцов по очереди двигаясь вниз, пока не дойду до конца строчек и в итоге удаляю. Скажу сразу, что этот вариант построен на немного измененном моем коде, поэтому, хотя и я прочитал про UBound - я всё равно не ощущаю себя уверенно в этом коде. Тут используется два цикла, потому что я подумал, что так будет правильней сравнивать строку i и строку i+1.
2-й вариант: Решил сделать два цикла - i и Z, и чтоб они шли параллельно друг другу, также перебирали каждый столбец, но уже не i и i+1 (это мне кажется плохая задумка, потому что тут он вроде как перебирает только две соседние строки).
Я думаю как-нибудь зациклить эти 18 условий для каждого столбца, чтоб был цикл и переменная от 2 до 19 (для каждого столбца) или вообще переделать их в сравнение не ячеек Cells, а в сравнение строчек Rows.
1-й вариант:

Visual Basic

Sub MMM()
'ZZZ = Timer
Application.ScreenUpdating = False
LR = Cells(Rows.Count, 2).End(xlUp).Row
 
Set RNG1 = Range(Cells(1, 2), Cells(LR, 19))
ARR1 = RNG1.Value
 
For i = 2 To LR
   For j = i + 1 To LR
        If ARR1(i, 2) = ARR1(j, 2) Then
                 If ARR1(i, 3) = ARR1(j, 3) Then
                    If ARR1(i, 4) = ARR1(j, 4) Then
                        If ARR1(i, 5) = ARR1(j, 5) Then
                            If ARR1(i, 6) = ARR1(j, 6) Then
                                If ARR1(i, 7) = ARR1(j, 7) Then
                                    If ARR1(i, 8) = ARR1(j, 8) Then
                                        If ARR1(i, 9) = ARR1(j, 9) Then
                                            If ARR1(i, 10) = ARR1(j, 10) Then
                                                If ARR1(i, 11) = ARR1(j, 11) Then
                                                    If ARR1(i, 12) = ARR1(j, 12) Then
                                                        If ARR1(i, 13) = ARR1(j, 13) Then
                                                            If ARR1(i, 14) = ARR1(j, 14) Then
                                                                If ARR1(i, 15) = ARR1(j, 15) Then
                                                                    If ARR1(i, 16) = ARR1(j, 16) Then
                                                                        If ARR1(i, 17) = ARR1(j, 17) Then
                                                                            If ARR1(i, 18) = ARR1(j, 18) Then
                                                                                If ARR1(i, 19) = ARR1(j, 19) Then
    For X = 2 To UBound(ARR1, 2)
    If ARR1(1, X) = ARR1(j, 2) Then ARR1(i, X).Delete
    Next X
    End If
                                                                                End If
                                                                            End If
                                                                        End If
                                                                    End If
                                                                End If
                                                            End If
                                                        End If
                                                    End If
                                                End If
                                            End If
                                        End If
                                    End If
                                End If
                            End If
                        End If
                    End If
                End If
Next j
Next i
RNG1.Value = ARR1
'MsgBox "Complete   " & Chr(13) & CStr(Timer - ZZZ) & "sec"
End Sub

2-й вариант:

Visual Basic

 Public Sub Inp()
Sub zzz()
LR = Cells(Rows.Count, 2).End(xlUp).Row
'MsgBox (LR)
For i = 2 To LR 
    For Z = 2 To LR
        If InStr(1, Cells(i, 2), Cells(Z, 2), 1) > 0 Then 
            If InStr(1, Cells(i, 3), Cells(Z, 3), 1) > 0 Then 
                If InStr(1, Cells(i, 4), Cells(Z, 4), 1) > 0 Then
                    If InStr(1, Cells(i, 5), Cells(Z, 5), 1) > 0 Then
                        If InStr(1, Cells(i, 6), Cells(Z, 6), 1) > 0 Then
                            If InStr(1, Cells(i, 7), Cells(Z, 7), 1) > 0 Then
                                If InStr(1, Cells(i, 8), Cells(Z, 8), 1) > 0 Then
                                    If InStr(1, Cells(i, 9), Cells(Z, 9), 1) > 0 Then
                                        If InStr(1, Cells(i, 10), Cells(Z, 10), 1) > 0 Then
                                            If InStr(1, Cells(i, 11), Cells(Z, 11), 1) > 0 Then
                                                If InStr(1, Cells(i, 12), Cells(Z, 12), 1) > 0 Then
                                                    If InStr(1, Cells(i, 13), Cells(Z, 13), 1) > 0 Then
                                                        If InStr(1, Cells(i, 14), Cells(Z, 14), 1) > 0 Then
                                                            If InStr(1, Cells(i, 15), Cells(Z, 15), 1) > 0 Then
                                                                If InStr(1, Cells(i, 16), Cells(Z, 16), 1) > 0 Then
                                                                    If InStr(1, Cells(i, 17), Cells(Z, 17), 1) > 0 Then
                                                                        If InStr(1, Cells(i, 18), Cells(Z, 18), 1) > 0 Then
                                                                            If InStr(1, Cells(i, 19), Cells(Z, 19), 1) > 0 Then
                                                                            Rows(i).Delete
                                                                            End If
                                                                        End If
                                                                    End If
                                                                End If
                                                            End If
                                                        End If
                                                    End If
                                                End If
                                            End If
                                        End If
                                    End If
                                End If
                            End If
                        End If
                    End If
                End If
            End If
        End If
    Next
Next
End Sub

@Narimanych · 05.12.2020, 16:20

serviktor,
Напишите конкретное задание.

Добавлено через 25 секунд
Что вы хотите?

@АЕ · 05.12.2020, 17:02

serviktor, а для 19-ти колонок не потребуется?

@serviktor · 05.12.2020, 18:55 **[ТС]**

Сообщение от Narimanych

Напишите конкретное задание

Удалить дубликаты, если имеется некоторое количество одинаковых строк (с диапазоном со второго по 19-й столбец, то оставить только одну такую строку, а ее копии удалить, и так со всеми строчками.

toiai · 05.12.2020, 18:59

Как вариант на словарях:

Visual Basic

Sub CopyUnicumNColumns()
    Dim t$, i&, k&
    a = ActiveSheet.UsedRange
    k = UBound(a)
    With CreateObject("Scripting.Dictionary")
        For i = 1 To k
            b = Application.Index(a, i, , 1)
            t = Join(b, "|")
            If Not .exists(t) Then .Item(t) = b
        Next
        Erase a
        Sheets.Add
        i = 1
        For Each x In .keys
            Cells(i, 1).Resize(1, k) = .Item(x)
            i = i + 1
        Next
    End With
End Sub

@serviktor · 05.12.2020, 19:11 **[ТС]**

Сообщение от АЕ

а для 19-ти колонок не потребуется?

Не потребуется, есть у меня одна идея, но не знаю как реализовать. В строке 1 находится шапка, то есть именно по ней можно определить то, сколько столбцов заполнено. Думаю, можно использовать метод наподобие Cells(Rows.Count, 2).End(xlUp).Row, только чтоб не количество заполненных строк считал, а количество столбцов, и занести это в переменную. Но этот вариант не обязательно реализовывать, да и у меня не получается его реализовать, это просто как идея, поэтому можно явно указать 18 колонок.

Добавлено через 4 минуты

Сообщение от toiai

Как вариант на словарях:

Выдает ошибку на строчке

Visual Basic

1	With CreateObject("Scripting.Dictionary")

Пишет: ActiveX component can't create object

toiai · 05.12.2020, 19:18

Вот файл

@serviktor · 05.12.2020, 19:22 **[ТС]**

Сообщение от toiai

Вот файл

Такая же ошибка

toiai · 05.12.2020, 19:23

Какой офис?

@serviktor · 05.12.2020, 19:24 **[ТС]**

Сообщение от toiai

Какой офис?

2019, а разве это может влиять?

toiai · 05.12.2020, 19:39

У меня 2010 и все работает, посмотри References:

@Narimanych · 05.12.2020, 19:39

serviktor,
Еще вариант ( в принципе такой же как и наверху , только в массивах)...
отработка на 100000 строк меньше 2 секунд

Кликните здесь для просмотра всего текста

Visual Basic

Sub MMM()
T1 = Timer
LR = Range("B:S").Find("*", , xlValues, xlWhole, , xlPrevious).Row
Set RNG1 = Range(Cells(1, 2), Cells(LR, 19))
ARR1 = RNG1.Value
ReDim ARR2(1 To UBound(ARR1))
 
    For i = 1 To UBound(ARR1)
         s = ""
            For j = 1 To UBound(ARR1, 2)
              s = s & ARR1(i, j) & ";"
            Next
         ARR2(i) = Mid(s, 1, Len(s) - 1)
    Next
    With CreateObject("Scripting.Dictionary")
            For i = 1 To UBound(ARR2)
              LL = .Item(ARR2(i))
            Next
     ReDim ARR3(1 To .Count, 1 To 18)
            For i = 1 To .Count
                   ARR4 = Split(.Keys()(i - 1), ";")
                    For j = 1 To 18
                      ARR3(i, j) = ARR4(j - 1)
                    Next
            Next
    End With
Sheets.Add After:=Worksheets(Worksheets.Count)
Cells(2, 1).Resize(UBound(ARR3), 18).Value = ARR3
 
MsgBox "Job Complete   " & Chr(13) _
& "Time spent : " & CStr(Timer - T1) & "  sec" & Chr(13) _
& LR - 1 & "  lines in total" & Chr(13) _
& UBound(ARR3) - 1 & " Original lines found"
End Sub

Файл приложен,нажатие кнопки МММ

@serviktor · 05.12.2020, 19:48 **[ТС]**

Сообщение от toiai

посмотри References

Отличается только тем, что у меня не 15.0, а 16.0, а так всё аналогично, галочки стоят

@КостяФедореев · 05.12.2020, 19:50

Сообщение от serviktor

Выдает ошибку на строчке
Visual BasicВыделить код
1
With CreateObject("Scripting.Dictionary")

У ТС Мак и думаю дело в этом

toiai · 05.12.2020, 19:51

Проверил в 2013 -работает.
Подправил ошибку по количеству стообцов

Visual Basic

Sub CopyUnicumNColumns()
    Dim t$, i&, k&
    a = ActiveSheet.UsedRange
    k = UBound(a, 2)
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a)
            b = Application.Index(a, i, , 1)
            t = Join(b, "|")
            If Not .exists(t) Then .Item(t) = b
        Next
        Erase a
        Sheets.Add
        i = 1
        For Each x In .keys
            Cells(i, 1).Resize(1, k) = .Item(x)
            i = i + 1
        Next
    End With
End Sub

@serviktor · 05.12.2020, 20:16 **[ТС]**

toiai, Narimanych, большое спасибо за помощь, возможно ошибка была из-за версии офиса, или из-за Mac оси, на винде офис всё удачно выполнил. Теперь знаю, в каком направлении двигаться и что подтянуть, чтобы решать подобные задачи)

@Narimanych · 05.12.2020, 20:17

serviktor,
Велкоме

Удаление дубликатов строк из диапазона, состоящего из 18-ти колонок

Решение

Решение

@Narimanych 2724 / 1701 / 776 Регистрация: 23.03.2015 Сообщений: 5,388
	05.12.2020, 16:20	2
	serviktor, Напишите конкретное задание. Добавлено через 25 секунд Что вы хотите? 0

@АЕ ᴁ® 3648 / 2004 / 427 Регистрация: 13.12.2016 Сообщений: 6,899 Записей в блоге: 5
	05.12.2020, 17:02	3
	serviktor, а для 19-ти колонок не потребуется? 0

@serviktor 5 / 4 / 1 Регистрация: 03.04.2018 Сообщений: 113
	05.12.2020, 18:55 [ТС]	4
	Сообщение от Narimanych Напишите конкретное задание Удалить дубликаты, если имеется некоторое количество одинаковых строк (с диапазоном со второго по 19-й столбец, то оставить только одну такую строку, а ее копии удалить, и так со всеми строчками. 0

@serviktor 5 / 4 / 1 Регистрация: 03.04.2018 Сообщений: 113
	05.12.2020, 19:22 [ТС]	8
	Сообщение от toiai Вот файл Такая же ошибка 0

toiai 3218 / 967 / 223 Регистрация: 29.05.2010 Сообщений: 2,086
	05.12.2020, 19:23	9
	Какой офис? 0

@serviktor 5 / 4 / 1 Регистрация: 03.04.2018 Сообщений: 113
	05.12.2020, 19:24 [ТС]	10
	Сообщение от toiai Какой офис? 2019, а разве это может влиять? 0

toiai 3218 / 967 / 223 Регистрация: 29.05.2010 Сообщений: 2,086
	05.12.2020, 19:39	11
	У меня 2010 и все работает, посмотри References: Миниатюры 1

@serviktor 5 / 4 / 1 Регистрация: 03.04.2018 Сообщений: 113
	05.12.2020, 19:48 [ТС]	13
	Сообщение от toiai посмотри References Отличается только тем, что у меня не 15.0, а 16.0, а так всё аналогично, галочки стоят 0

@КостяФедореев Часто онлайн 864 / 579 / 263 Регистрация: 09.01.2017 Сообщений: 1,951
	05.12.2020, 19:50	14
	Сообщение от serviktor Выдает ошибку на строчке Visual BasicВыделить код 1 With CreateObject("Scripting.Dictionary") У ТС Мак и думаю дело в этом 0

@serviktor 5 / 4 / 1 Регистрация: 03.04.2018 Сообщений: 113
	05.12.2020, 20:16 [ТС]	16
	toiai, Narimanych, большое спасибо за помощь, возможно ошибка была из-за версии офиса, или из-за Mac оси, на винде офис всё удачно выполнил. Теперь знаю, в каком направлении двигаться и что подтянуть, чтобы решать подобные задачи) 0

@Narimanych 2724 / 1701 / 776 Регистрация: 23.03.2015 Сообщений: 5,388
	05.12.2020, 20:17	17
	serviktor, Велкоме 0