Найти дубли на большом количестве строк.

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Найти дубли на большом количестве строк. (Макросы/Sub)

Mark1976

Дата: Вторник, 04.12.2018, 07:35 | Сообщение № 1

Группа: Проверенные

Ранг: Ветеран

Сообщений: 761

Репутация: 3 ±

Замечаний: 0% ±

Excel 2010, 2013

Здравствуйте. Есть таблица с большим количеством строк. Необходимо найти дубли. Встроенными средствами эксель это сделать сложно (большой объем строк). Возможно эту задачу решить макросом, для ускорения процесса поиска дублей? Пример прилагается.

К сообщению приложен файл: -1-1.xlsx (8.3 Kb)

Ответить

boa

Дата: Вторник, 04.12.2018, 09:43 | Сообщение № 2

Группа: Друзья

Ранг: Ветеран

Сообщений: 559

Репутация: 167 ±

Замечаний: 0% ±

365

Mark1976,
ну если хотите формулами, то

Код

=IF(COUNTIF(C1;RC1)>1;"ok";"")

а можно не условным форматированием искать, а сразу их удалить. Есть встроенная возможность "Удалить дубликаты"

Ответить

_Boroda_

Дата: Вторник, 04.12.2018, 09:57 | Сообщение № 3

Группа: Админы

Ранг: Местный житель

Сообщений: 16718

Репутация: 6505 ±

Замечаний: ±

2003; 2007; 2010; 2013 RUS

Так нужно?
[vba]

Код

Sub tt()
    Application.ScreenUpdating = 0
    met_ = "ок"
    n_ = Cells(Rows.Count, 1).End(3).Row - 1
    Cells(2, 3) = 1
    Cells(2, 3).Resize(n_).DataSeries
    With Me.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Cells(1, 1).Resize(n_ + 1)
        .SetRange Cells(1, 1).Resize(n_ + 1, 3)
        .Apply
    End With
    ar = Cells(2, 1).Resize(n_, 2)
    For i = 1 To n_ - 1
        If ar(i, 1) = ar(i + 1, 1) Then
            ar(i, 2) = met_
            ar(i + 1, 2) = met_
            i = i + 1
        End If
    Next i
    If ar(n_, 1) = ar(n_ - 1, 1) Then ar(n_, 2) = met_
    Cells(2, 1).Resize(n_, 2) = ar
    With Me.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Cells(1, 3).Resize(n_ + 1)
        .SetRange Cells(1, 1).Resize(n_ + 1, 3)
        .Apply
    End With
    Cells(2, 3).Resize(n_).Clear
    Application.ScreenUpdating = 0 = 1
End Sub

[/vba]

К сообщению приложен файл: -1-1_1.xlsm (16.6 Kb)

Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995

Ответить

ABC

Дата: Вторник, 04.12.2018, 10:03 | Сообщение № 4

Группа: Друзья

Ранг: Обитатель

Сообщений: 397

Репутация: 112 ±

Замечаний: 0% ±

Excel 2007

[vba]

Код

Sub Test()
    Dim arr(), i&, ii&, arr2, yes
    arr = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value

    With CreateObject("Scripting.Dictionary")
        For i = LBound(arr, 1) To UBound(arr, 1)
            .Item(arr(i, 1)) = .Item(arr(i, 1)) & ", " & arr(i, 1)
        Next i

        ReDim arr2(1 To .Count, 1 To 2)
        i = 1
        For Each arr(i, 1) In .Keys
            ii = 1
            For Each yes In Split(Mid(.Item(arr(i, 1)), 3), ", ")
                arr2(i, 1) = Split(yes, ",")(0)
                arr2(i, 2) = ii
                ii = ii + 1
            Next
            i = i + 1
        Next
    End With
    [d2].Resize(i - 1, 2).Value = arr2
End Sub

[/vba]