Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Найти дубли на большом количестве строк. - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Найти дубли на большом количестве строк. (Макросы/Sub)
Найти дубли на большом количестве строк.
Mark1976 Дата: Вторник, 04.12.2018, 07:35 | Сообщение № 1
Группа: Проверенные
Ранг: Ветеран
Сообщений: 521
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Здравствуйте. Есть таблица с большим количеством строк. Необходимо найти дубли. Встроенными средствами эксель это сделать сложно (большой объем строк). Возможно эту задачу решить макросом, для ускорения процесса поиска дублей? Пример прилагается.
К сообщению приложен файл: -1-1.xlsx(8.3 Kb)
 
Ответить
СообщениеЗдравствуйте. Есть таблица с большим количеством строк. Необходимо найти дубли. Встроенными средствами эксель это сделать сложно (большой объем строк). Возможно эту задачу решить макросом, для ускорения процесса поиска дублей? Пример прилагается.

Автор - Mark1976
Дата добавления - 04.12.2018 в 07:35
boa Дата: Вторник, 04.12.2018, 09:43 | Сообщение № 2
Группа: Проверенные
Ранг: Обитатель
Сообщений: 277
Репутация: 57 ±
Замечаний: 0% ±

2013, 365
Mark1976,
ну если хотите формулами, то
Код
=IF(COUNTIF(C1;RC1)>1;"ok";"")

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


 
Ответить
СообщениеMark1976,
ну если хотите формулами, то
Код
=IF(COUNTIF(C1;RC1)>1;"ok";"")

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

Автор - boa
Дата добавления - 04.12.2018 в 09:43
_Boroda_ Дата: Вторник, 04.12.2018, 09:57 | Сообщение № 3
Группа: Модераторы
Ранг: Местный житель
Сообщений: 13681
Репутация: 5580 ±
Замечаний: 0% ±

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
 
Ответить
СообщениеТак нужно?
[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]

Автор - _Boroda_
Дата добавления - 04.12.2018 в 09:57
ABC Дата: Вторник, 04.12.2018, 10:03 | Сообщение № 4
Группа: Друзья
Ранг: Обитатель
Сообщений: 393
Репутация: 110 ±
Замечаний: 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]


MS Excel 2007 and 2010...
-------------------------------
С Уважением, Даулет


Сообщение отредактировал ABC - Вторник, 04.12.2018, 10:06
 
Ответить
Сообщение[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]

Автор - ABC
Дата добавления - 04.12.2018 в 10:03
Mark1976 Дата: Вторник, 04.12.2018, 11:10 | Сообщение № 5
Группа: Проверенные
Ранг: Ветеран
Сообщений: 521
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
_Boroda_, да спасибо.
 
Ответить
Сообщение_Boroda_, да спасибо.

Автор - Mark1976
Дата добавления - 04.12.2018 в 11:10
Mark1976 Дата: Вторник, 04.12.2018, 11:11 | Сообщение № 6
Группа: Проверенные
Ранг: Ветеран
Сообщений: 521
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
ABC, Спасибо
 
Ответить
СообщениеABC, Спасибо

Автор - Mark1976
Дата добавления - 04.12.2018 в 11:11
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Найти дубли на большом количестве строк. (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования
© 2010-2018 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!