Vba excel поиск повторяющихся значений

Поиск повторяющихся значений (дубликатов) в одном из столбцов таблицы Excel и выделение их цветом заливки с помощью кода VBA.

Поиск дубликатов в столбце

Чаще всего повторяющиеся значения ищут в первом столбце таблицы, поэтому процедуру поиска дубликатов в VBA Excel рассмотрим именно на нем:

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

Sub DuplicateSearch()

Dim ps As Long, myRange As Range, i1 As Long, i2 As Long

‘Определяем номер последней строки таблицы

ps = Cells(1, 1).CurrentRegion.Rows.Count

    ‘Нет смысла искать дубликаты в таблице, состоящей из одной строки

    If ps > 1 Then

    ‘Присваиваем объектной переменной ссылку на исследуемый столбец

    Set myRange = Range(Cells(1, 1), Cells(ps, 1))

        With myRange

        ‘Очищаем ячейки столбца от предыдущих закрашиваний

        .Interior.Color = xlNone

            For i1 = 1 To ps 1

                For i2 = i1 + 1 To ps

                    If .Cells(i1) = .Cells(i2) Then

                        ‘Если значения сравниваемых ячеек совпадают,

                        ‘обеим присваиваем новый цвет заливки

                        .Cells(i1).Interior.Color = 6740479

                        .Cells(i2).Interior.Color = 6740479

                    End If

                Next

            Next

        End With

    End If

End Sub

После ручного исправления или удаления повторяющихся значений, запускаем процедуру DuplicateSearch вновь, чтобы очистить от заливки ячейки столбца с уникальными значениями и заново выделить оставшиеся дубликаты.

Чтобы найти повторы в другом столбце, замените номер столбца в параметрах свойства Cells (в трех местах процедуры DuplicateSearch).

Константы для заливки

Для указания цвета заливки для ячеек с повторяющимися значениями вместо числового значения цвета можно использовать предопределенные константы:

Предопределенная константа Наименование цвета
vbBlack Черный
vbBlue Голубой
vbCyan Бирюзовый
vbGreen Зеленый
vbMagenta Пурпурный
vbRed Красный
vbWhite Белый
vbYellow Желтый

 

mtts54

Пользователь

Сообщений: 164
Регистрация: 10.09.2015

Добрый день, уважаемые форумчане! В поиске есть аналогичные темы, но подходящего мне я не нашел. Суть проблемы: есть табличка ~200 тыс. строк на 60 столбцов. В столбце G — некий идентификатор id, он может быть уникальным, а может повторяться. Буду благодарен за помощь с помощью VBA найти и вырезать из данной таблицы строки с повторяющимися id и перенести их на другой лист.

Excel непознаваем как атом.

 

Возможно я не правильно понял задачу…. Но самый простой вариант
Выделяем столбец G, на вкладке Главная — выбираем условное форматирование —> Правила выделения ячеек —> Повторяющиеся значения (что бы все повторяющиеся ID подсвечивались)
Далее устанавливаем в столбце G фильтр —> Фильтр по цвету —> выбираем цвет повторения (красный по умолчанию).
Автоматом получили все повторяющиеся ID отфильтрованные, теперь мы просто их копируем и вставляем на другой лист.
Прошу простить, если не правильно понял задачу=)

 

Если нужен именно макрос, то делаем все тоже самое через макрорекодер (за исключением выделения ячеек отфильтрованных, для копирования).
Про копирование кратко написано в этой теме

https://www.planetaexcel.ru/forum/?PAGE_NAME=read&FID=1&TID=47173

 

Jack Famous

Пользователь

Сообщений: 10848
Регистрация: 07.11.2014

OS: Win 8.1 Корп. x64 | Excel 2016 x64: | Browser: Chrome

mtts54, здравствуйте!
Не совсем понятно, как переносить… Просто все дубли, как описал Михаил Комиссаров? Уточните в файле примере конечный результат…

Изменено: Jack Famous15.08.2018 11:14:43

Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄

 

TheBestOfTheBest

Пользователь

Сообщений: 2366
Регистрация: 03.04.2015

Excel 2010 +PLEX +SaveToDB +PowerQuery

С помощью доп.столбца. Файл положить в папку С:1, на таблице ПКМ-обновить.

Неизлечимых болезней нет, есть неизлечимые люди.

 

mtts54

Пользователь

Сообщений: 164
Регистрация: 10.09.2015

Михаил Комиссаров

, автофильтр «видит» только 10 тыс. строк, поэтому этот прием не годится.

Jack Famous

, конечный результат в файле-примере таков: на Листе1 строк с подсвеченными id не должно быть — они должны появиться на другом, вставленном листе. В реальном файле из-за большого количества строк УФ неприменимо.

Excel непознаваем как атом.

 

mtts54

Пользователь

Сообщений: 164
Регистрация: 10.09.2015

TheBestOfTheBest

, не совсем то, что необходимо: в Вашем решении одна из повторяющихся строк остается на исходном листе. Мне же нужно ВСЕ строки с повторяющимися id вырезать с исходного листа и вставить на другой лист. Честно говоря, я не понял, каким приемом Вы решили задачу. Спасибо за ответ.

Excel непознаваем как атом.

 

Jack Famous

Пользователь

Сообщений: 10848
Регистрация: 07.11.2014

OS: Win 8.1 Корп. x64 | Excel 2016 x64: | Browser: Chrome

#8

15.08.2018 13:19:11

mtts54, пробуйте

Код на массивах

UPD (15:05):

14я строка кода Set rng = Cells(1, col).Resize(r+ 1, 1) исправлена на Set rng = Cells(2, col).Resize(r, 1). Файл заменён.

Прикрепленные файлы

  • Поиск повторов.xlsm (63.08 КБ)

Изменено: Jack Famous15.08.2018 15:07:53

Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄

 

Ігор Гончаренко

Пользователь

Сообщений: 13746
Регистрация: 01.01.1970

#9

15.08.2018 14:30:52

выполните этот макрос

Код
Sub RemoveDouble2NewSheet()
  Dim rg As Range: Set rg = Range(Cells(2, 7), Cells(Rows.Count, 7).End(xlUp))
  rg.Offset(0, 9).FormulaR1C1 = "=if(countif(r2c7:r" & rg.Rows.Count + 1 & "c7, rc7)>1,2,"""")"
  rg.Offset(0, 9).Value = rg.Offset(0, 9).Value
  Set rg = rg.Offset(0, 9).SpecialCells(xlCellTypeConstants, 1).EntireRow: Columns(16).Clear
  rg.Copy Worksheets.Add.Cells(1, 1):  rg.Delete: Columns(16).Clear
End Sub

при активном листе с данными

Изменено: Ігор Гончаренко15.08.2018 14:34:29

Программисты — это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!

 

TheBestOfTheBest

Пользователь

Сообщений: 2366
Регистрация: 03.04.2015

Excel 2010 +PLEX +SaveToDB +PowerQuery

#10

15.08.2018 14:39:42

Цитата
mtts54 написал:
Честно говоря, я не понял, каким приемом Вы решили задачу. Спасибо за ответ.

Внешний запрос (Данные-Получение внешних данных…). Измените формулу в столбце Ключ =СЧЁТЕСЛИ($G$2:$G$348;G2), обновите таблицы как указано выше.

Изменено: TheBestOfTheBest15.08.2018 14:40:31

Неизлечимых болезней нет, есть неизлечимые люди.

 

кузя1972

Пользователь

Сообщений: 189
Регистрация: 10.12.2017

#11

15.08.2018 16:37:15

вариант макроса(не нашел как надо в исходном файл -примере),кнопки unic и очистка,лист1 добавлен вручную

Код
Sub unic()
     Dim i&, m&, j&, z, z1: z = Range("A2:O" & Range("A" & Rows.Count).End(xlUp).Row).Value
     ReDim z1(1 To UBound(z), 1 To UBound(z, 2))
 With CreateObject("scripting.dictionary"): .CompareMode = 1
 For i = 1 To UBound(z): .Item(z(i, 7)) = .Item(z(i, 7)) + 1: Next
 For i = 1 To UBound(z)
 If .Item(z(i, 7)) > 1 Then
   m = m + 1: For j = 1 To UBound(z, 2): z1(m, j) = z(i, j): Next
 End If
 Next
 Sheets("Лист1").Range("A1").Resize(m, UBound(z1, 2)).Value = z1
End With
End Sub

Прикрепленные файлы

  • example_16_08_2018_pl_повторы.xls (146.5 КБ)

Изменено: кузя197215.08.2018 16:37:30

 

mtts54

Пользователь

Сообщений: 164
Регистрация: 10.09.2015

Коллеги, спасибо за ответы. Сегодня тестировать некогда (комп занят расчетами), отпишусь завтра.

Excel непознаваем как атом.

 

Jack Famous

Пользователь

Сообщений: 10848
Регистрация: 07.11.2014

OS: Win 8.1 Корп. x64 | Excel 2016 x64: | Browser: Chrome

mtts54, мы ждём (ну я точно жду фидбэк)  :D

Изменено: Jack Famous16.08.2018 10:15:51

Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄

 

Nordheim

Пользователь

Сообщений: 3154
Регистрация: 18.04.2017

#14

16.08.2018 10:51:18

Вариант на массивах и словарях

Скрытый текст

«Все гениальное просто, а все простое гениально!!!»

 

mtts54

Пользователь

Сообщений: 164
Регистрация: 10.09.2015

Добрый день! Протестировал макрос от

Ігор Гончаренко

на реальном файле размером 31 колонка на 153 тыс.строк. В макросе в выражениях Offset(0, 9) заменил 9 на 25 и в Columns(16)  заменил 16 на 32. Макрос работал ок. 10 минут, нашел все 7696 повторов. Хотелось бы побыстрее, но… размер имеет значение. Спасибо! Остальные решения протестирую завтра.

Excel непознаваем как атом.

 

mtts54

Пользователь

Сообщений: 164
Регистрация: 10.09.2015

Попробовал на том же реальном файле макрос от

Jack Famous

. К сожалению, макрос где-то зациклился и после 20 минут ожидания я был вынужден остановить его выполнение :(  

Excel непознаваем как атом.

 

Jack Famous

Пользователь

Сообщений: 10848
Регистрация: 07.11.2014

OS: Win 8.1 Корп. x64 | Excel 2016 x64: | Browser: Chrome

#17

17.08.2018 11:45:00

mtts54, немного изменил принцип удаления строк из исходника — пробуйте

КОД

Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄

 

mtts54

Пользователь

Сообщений: 164
Регистрация: 10.09.2015

На том же реальном файле макрос

Nordheim

за 2 секунды нашел все повторы, вставил лист и скопировал повторы туда (правда, пару раз VBA ругнулся: не была объявлена переменная sht1 — это я поправил).  Но с исходного листа макрос повторы не удалил  :( . Тут я ничего поделать не смог  :cry:  . Очень надеюсь, что уважаемый  

Nordheim

 прочтет этот пост и подправит код :oops:  

Excel непознаваем как атом.

 

Jack Famous

Пользователь

Сообщений: 10848
Регистрация: 07.11.2014

OS: Win 8.1 Корп. x64 | Excel 2016 x64: | Browser: Chrome

mtts54, вы бы выложили ссылку на файл реального объёма, но без конфиденциальных данных — тестить проще было бы

Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄

 

Nordheim

Пользователь

Сообщений: 3154
Регистрация: 18.04.2017

#20

17.08.2018 12:27:31

В данном коде есть нюанс, таблица должна начинаться со второй строки, шапка таблицы на первой

Код
Option Explicit

 
Sub test()
'   ----------------------------------------------
    Dim dic As Object, ikey, rng As Range
    Dim i&, arr(), txt$, j%, x&, sht As Worksheet
'   ----------------------------------------------
    Application.DisplayAlerts = False
    Set dic = CreateObject("Scripting.Dictionary")
    On Error Resume Next
    Set sht = ThisWorkbook.Worksheets("Дубли")
    If Not sht Is Nothing Then sht.Delete
    On Error GoTo 0
    arr = sht1.UsedRange.Value
    For i = 2 To UBound(arr)
        txt = arr(i, 7)
        dic.Item(txt) = dic.Item(txt) + 1
    Next i
    For Each ikey In dic.Keys
        If dic.Item(ikey) = 1 Then dic.Remove (ikey)
    Next ikey
    x = 1
    For i = 1 To UBound(arr)
        txt = arr(i, 7)
        If dic.Exists(txt) Then
            If rng Is Nothing Then Set rng = sht1.Rows(i) Else Set rng = Union(rng, sht1.Rows(i))
            x = x + 1
            For j = 1 To UBound(arr, 2)
                arr(x, j) = arr(i, j)
            Next j
        End If
    Next i
    Set sht = ThisWorkbook.Worksheets.Add(after:=sht1)
    With sht
        .[a1].Resize(x, UBound(arr, 2)) = arr
        .Name = "Дубли"
        .Columns.AutoFit
    End With
    If Not rng Is Nothing Then rng.Delete
    Application.DisplayAlerts = True
End Sub

«Все гениальное просто, а все простое гениально!!!»

 

Kuzmich

Пользователь

Сообщений: 7998
Регистрация: 21.12.2012

#21

17.08.2018 12:36:19

Nordheim,  
Определите sht1    

Код
  Set sht1 = ThisWorkbook.Worksheets("Пример на форум")

при формировании листа Дубли я бы добавил первой строку

Код
.Range("K2:K" & x).NumberFormat = "@"

Изменено: Kuzmich17.08.2018 12:48:30

 

mtts54

Пользователь

Сообщений: 164
Регистрация: 10.09.2015

Excel непознаваем как атом.

 

kryptonets

Пользователь

Сообщений: 5
Регистрация: 20.01.2018

Я вижу,что нужен макрос. Но предложу другое решение. Надстройка PowerQuery. Выделить таблицу Ctrl+T, с заголовками.PowerQuery—>Из таблицы,диапазона.Главная—>Сохранять строки—>Сохранять дубликаты.Выгрузить.Готово)

 

Nordheim

Пользователь

Сообщений: 3154
Регистрация: 18.04.2017

#24

17.08.2018 13:03:43

Цитата
Kuzmich написал:
Определите sht1

sht1 в файле это название листа в VBAProject, поэтому лист не объявлен, на кириллице неудобно было писать, поэтому переименовал по ходу написания кода

«Все гениальное просто, а все простое гениально!!!»

 

Nordheim

Пользователь

Сообщений: 3154
Регистрация: 18.04.2017

#25

17.08.2018 13:05:09

Цитата
Kuzmich написал:
при формировании листа Дубли я бы добавил первой строку

С какой целью?

«Все гениальное просто, а все простое гениально!!!»

 

mtts54

Пользователь

Сообщений: 164
Регистрация: 10.09.2015

Nordheim

,  макрос (с учетом от

Kuzmich

) отработал немного дольше (это абсолютно не критично), повторы с исходного листа удалил. Спасибо!

kryptonets

, нужен именно макрос, т.к. таблица обрабатывается макросом (моим) и прерывать его для ручной работы неудобно. Тем не менее попробую Вашу идею — лишних знаний ведь не бывает, когда-нибудь пригодится. Спасибо.

Excel непознаваем как атом.

 

Kuzmich

Пользователь

Сообщений: 7998
Регистрация: 21.12.2012

#27

17.08.2018 13:17:04

Nordheim, написал

Цитата
С какой целью?

Просто на листе Дубли в столбце К появляются ячейки с янв.92 вместо 1-92

Изменено: Kuzmich17.08.2018 13:17:18

 

Nordheim

Пользователь

Сообщений: 3154
Регистрация: 18.04.2017

#28

17.08.2018 13:18:40

Цитата
Kuzmich написал:
Просто на листе Дули в столбце К появляются ячейки с янв.92 вместо 1-92

А строка зачем?

«Все гениальное просто, а все простое гениально!!!»

 

Kuzmich

Пользователь

Сообщений: 7998
Регистрация: 21.12.2012

#29

17.08.2018 13:22:51

Я имел в виду этот кусок макроса

Код
    With sht
        .Range("K2:K" & x).NumberFormat = "@"
        .[a1].Resize(x, UBound(arr, 2)) = arr
        .Name = "Дубли"
        .Columns.AutoFit
    End With

Чтобы не было преобразования в дату

 

Nordheim

Пользователь

Сообщений: 3154
Регистрация: 18.04.2017

#30

17.08.2018 13:23:27

Наверно так более правильно.

Код
Sub test()
'   ----------------------------------------------
    Dim dic As Object, ikey, rng As Range, sht1 As Worksheet
    Dim i&, arr(), txt$, j%, x&, sht As Worksheet
'   ----------------------------------------------
    Application.DisplayAlerts = False
    Set dic = CreateObject("Scripting.Dictionary")
    On Error Resume Next
    Set sht = ThisWorkbook.Worksheets("Дубли")
    If Not sht Is Nothing Then sht.Delete
    On Error GoTo 0
    Set sht1 = Worksheets("имя листа")
    arr = sht1.UsedRange.Value
    For i = 2 To UBound(arr)
        txt = arr(i, 7)
        dic.Item(txt) = dic.Item(txt) + 1
    Next i
    For Each ikey In dic.Keys
        If dic.Item(ikey) = 1 Then dic.Remove (ikey)
    Next ikey
    x = 1
    For i = 1 To UBound(arr)
        txt = arr(i, 7)
        If dic.Exists(txt) Then
            If rng Is Nothing Then Set rng = sht1.Rows(i) Else Set rng = Union(rng, sht1.Rows(i))
            x = x + 1
            For j = 1 To UBound(arr, 2)
                arr(x, j) = arr(i, j)
            Next j
        End If
    Next i
    Set sht = ThisWorkbook.Worksheets.Add(after:=sht1)
    With sht
       .Range("K2:K" & x).NumberFormat = "@"
       .[a1].Resize(x, UBound(arr, 2)).Value = arr
        End With
        .Name = "Дубли"
        .Columns.AutoFit
    End With
    If Not rng Is Nothing Then rng.Delete
    Application.DisplayAlerts = True
End Sub

Изменено: Nordheim17.08.2018 13:25:52

«Все гениальное просто, а все простое гениально!!!»

Очень часто при работе c таблицами Excel возникают ситуации, в которых необходимо сравнить несколько списков, найти в них повторяющиеся значения и что-то с ними сделать.  Оптимальный способ поиска и обработки дубликатов должен быть выбран в зависимости от типа исходных данных и желаемого результата. Цель данной статьи — разобрать все возможные варианты обработки дубликатов в Excel в одной статье для того, чтобы читатель мог выбрать оптимальный вариант для любой ситуации.

Оглавление:

  • Выделение
    • Поиск и выделение повторяющихся значений ячеек в одном списке — условное форматирование
    • Поиск и выделение повторяющихся значений ячеек в нескольких списках — условное форматирование
    • Поиск и выделение повторяющихся значений ячеек — макрос Excel-VBA
    • Поиск и выделение повторяющегося текста внутри ячеек — макрос Excel VBA
  • Замена
    • Замена дублирующихся значений ячеек с помощью макроса Excel-VBA
    • Подстановка в другие таблицы
    • Функция ВПР (VLOOKUP)
    • Комбинация функций ИНДЕКС + ПОИСКПОЗ (INDEX+MATCH)+СЧЁТ()+ЕСЛИ()
  • Подсчёт
    • Посчитать количество повторений в одном списке
    • Сравнение двух списков используя формулу подсчёта повторений
    • Подсчёт количества повторений значений в строках с помощью макросов Excel-VBA
    • Функция СЧЁТЕСЛИ (COUNTIF)
  • Поиск
    • Поиск повторений значений в ячейках с помощью макроса Excel-VBA
    • Скрытие
    • Сортировка и фильтр
    • Скрытие строк с помощью макроса Excel-VBA
  • Удаление
    • Данные -> удалить дубликаты
    • Умные таблицы. Форматировать как таблицу -> удалить дубликаты

Функции в каждом разделе описаны в порядке возрастания их сложности и трудоемкости использования.


Выделение


Поиск и выделение повторяющихся значений ячеек в одном списке — условное форматирование

1. Выделить все значения в списке 

Образец списка с дубликатами Excel

2. Вкладка «Главная» -> Условное форматирование -> Правила выделения ячеек -> Повторяющиеся значения

Условное форматирование дубликатов в Excel

3. Выбрать необходимый формат (в данном случае выбран красный шрифт на светло-красном фоне)

Условное форматирование дубликатов в Excel

Результат:

Список Excel с дубликатами, выделенными с помощью условного форматирования

Если применить данное условное форматирование ко всему столбцу A, то все новые дубликаты, добавленные после строки 10 также будут отформатированы по заданному правилу.

Столбец с дубликатами, выделенными с помощью условного форматирования

Поиск и выделение повторяющихся значений ячеек в нескольких списках — условное форматирование

Сначала необходимо выделить столбцы (диапазоны ячеек) с дубликатами. Далее необходимо проделать действия, описанные в предидушем разделе начиная с шага 2.

 Списки с дубликатами, выделенными с помощью условного форматирования

Недостаток данного способа выделения дубликатов — визуально не определить, продублированы ли значения внутри каждого из списков, или между списками. В данном примере «малина» дублируется внутри списка 1, а «банан» и «груша» выделены потому что они продублированы между списками.

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

1. Выделяем первый столбец:

2. Вкладка «Главная» -> Условное форматирование -> Правила выделения ячеек -> Повторяющиеся значения

 Условное форматирование дубликатов в Excel

3. Пользовательский формат

4. Выбираем, например, одинарное подчеркивание, жирный шрифт и фиолетовый цвет.

5. Повторяем операцию с шага 2 для столбца B и получаем:

Два списка с дубликатами, выделенными с помощью условного форматирования

Поиск и выделение повторяющихся значений ячеек — макрос Excel-VBA

Скачать пример в Excel

 

Sub search_highlight_duplicates()

Dim Arr(16, 1) As String 'сравниваем значения как текст
'массив двухмерный
'16 на 2
'элементы 1-16,0 содержат значения ячеек
'элементы 1-16,1 - является ли соответсвующее значение дубликатом


For i = 1 To 16
Arr(i, 0) = ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Value 'записываем в массив
Next i


For k = 1 To UBound(Arr, 1)
CurrentItem = Arr(k, 0) 'достаём по одному элементы из массива 1-16,0
    For i = 1 To UBound(Arr, 1)
    If CurrentItem = Arr(i, 0) And i <> k Then Arr(i, 1) = "COPY"
    'сравниваем с другими элементами массива (за исключением себя самого)
    'для копий записываем в 1-16,0 "COPY"
    Next i
Next k


For i = 1 To UBound(Arr, 1)
    ThisWorkbook.Sheets("Sheet1").Cells(i, 2).Value = Arr(i, 1)
    'запишем результат обратно в таблицу в колонку 2
    'либо здесь можно прописать особенное форматирование для каждого элемента исходного массива
Next i

End Sub

То же самое, но через форматирование ячеек:

Скачать пример в Excel

Sub search_highlight_duplicates()

Dim Arr(16, 1) As String

For i = 1 To 16
Arr(i, 0) = ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Value
Next i

For k = 1 To UBound(Arr, 1)
CurrentItem = Arr(k, 0)
    For i = 1 To UBound(Arr, 1)
    If CurrentItem = Arr(i, 0) And i <> k Then Arr(i, 1) = "COPY"
    Next i
Next k


For i = 1 To UBound(Arr, 1)
If Arr(i, 1) = "COPY" Then
    With ThisWorkbook.Sheets("Sheet1").Cells(i, 1)
        With .Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 65535
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        With .Font
            .Color = -16776961
            .TintAndShade = 0
        End With
    End With
End If
    
Next i
End Sub

Поиск и выделение повторяющегося текста внутри ячеек — макрос Excel VBA

 Возможно существуют и другие более эффективные способы выделения копий слов внутри ячеек, но здесь будет описан только простейший способ, на который натолкнёт запись действий макрорекордером. Если мы напишем длинный текст в ячейке, включим запись макроса и отформатируем часть текста в ячейке, то получим примерно следующее: 

Таким образом, для выделения отдельных слов в ячейке нам нужно предварительно найти, где расположен нужный нам набор символов, а также его длину для каждого повторения.


Замена


Замена дублирующихся значений ячеек с помощью макроса Excel-VBA

Подстановка в другие таблицы

Функция ВПР (VLOOKUP)

Об использовании функции ВПР пошагово.

Комбинация функций ИНДЕКС + ПОИСКПОЗ (INDEX+MATCH)+СЧЁТ()+ЕСЛИ()

Если таблица, из которой мы хотим доставать значения для подстановки содержит дубликаты, то использование функции ВПР может не дать нужного результата, так как ВПР использует первое попавшееся совпадение и результат будет зависит от сортировки.


Подсчёт


Посчитать количество повторений в одном списке

Сравнение двух списков используя формулу подсчёта повторений

Подсчёт количества повторений значений в строках с помощью макросов Excel-VBA

Функция СЧЁТЕСЛИ (COUNTIF)


Поиск


Поиск повторений значений в ячейках с помощью макроса Excel-VBA


Скрытие


Сортировка и фильтр

Скрытие строк с помощью макроса Excel-VBA


Удаление


Данные -> удалить дубликаты

Умные таблицы. Форматировать как таблицу -> удалить дубликаты

23 / 23 / 12

Регистрация: 13.09.2010

Сообщений: 88

1

Поиск одинаковых значений в столбце

26.09.2011, 14:41. Показов 23032. Ответов 11


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

Добрый день.

Не могу разобраться с одной задачей на Excel.

Дан одномерный массив, занесенный в столбец Excel. Необходимо найти количество повторений числа, но только того которое стоит раньше, чем другие числа имеющие повторения…


Например:

7
5
3
1
2
3
4
5
0
1

В итоге получается что необходимо посчитать сколько «

5» у нас в массиве. Также нужно посчитать на какой позиции находится первая считаемая цифра (в нашем случае «5» на позиции 2).



0



15136 / 6410 / 1730

Регистрация: 24.09.2011

Сообщений: 9,999

26.09.2011, 15:44

2

Со вспомогательным столбцом:



2



23 / 23 / 12

Регистрация: 13.09.2010

Сообщений: 88

26.09.2011, 17:07

 [ТС]

3

Спасибо огромное, а как это изобразить в виде макроса?



0



19vitek

730 / 406 / 95

Регистрация: 19.12.2010

Сообщений: 756

26.09.2011, 17:43

4

Лучший ответ Сообщение было отмечено Памирыч как решение

Решение

как вариант.

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
Sub n()
For i = 1 To 10
Cells(i, 2) = Application.WorksheetFunction.CountIf([a1:a10], Cells(i, 1))
Next i
For Each cel In [b1:b10]
If cel.Value > 1 Then
Cells(1, 5) = "Цифра " & Cells(cel.Row, 1) & " стоит первой в массиве "
Cells(2, 5) = "и повторяется " & Cells(cel.Row, 2) & " раз(a)"
Cells(3, 5) = "ее индекс в массиве " & cel.Row
Exit For
End If
Next cel
End Sub

Вложения

Тип файла: xls Подсчет повторов_1.xls (32.0 Кб, 362 просмотров)



1



Казанский

15136 / 6410 / 1730

Регистрация: 24.09.2011

Сообщений: 9,999

26.09.2011, 17:51

5

Можно так:

Visual Basic
1
2
3
4
5
6
7
8
Sub malenkaya()
Dim i&, j&, v()
On Error Resume Next
i = Cells(Rows.Count, 1).End(xlUp).Row
v = Evaluate("INDEX(COUNTIF(A1:A" & i & ",A1:A" & i & ")>1,)")
j = WorksheetFunction.Match(True, v, 0)
MsgBox "позиция: " & j & vbLf & "число: " & [A1].Cells(j)
End Sub



2



23 / 23 / 12

Регистрация: 13.09.2010

Сообщений: 88

26.09.2011, 19:18

 [ТС]

6

спасибо большое!!!

Добавлено через 3 минуты
извените за беспокойство, а можно узнать индексы всех повторяеммых чисел, или хотя-бы второй?

ну вроде индекс 1-ой 5 — 2
индекс 2-ой 5 — 8



0



19vitek

730 / 406 / 95

Регистрация: 19.12.2010

Сообщений: 756

26.09.2011, 19:29

7

Лучший ответ Сообщение было отмечено Памирыч как решение

Решение

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub n()
For i = 1 To 10
Cells(i, 2) = Application.WorksheetFunction.CountIf([a1:a10], Cells(i, 1))
Next i
For Each cel In [b1:b10]
If cel.Value > 1 Then
Cells(1, 5) = "Цифра " & Cells(cel.Row, 1) & " стоит первой в массиве "
Cells(2, 5) = "и повторяется " & Cells(cel.Row, 2) & " раз(a)"
Cells(3, 5) = "ее индекс в массиве " & cel.Row
Exit For
End If
Next cel
For Each cel In [b1:b10]
If cel.Value > 1 Then Cells(cel.Row, 3) = cel.Row
Next cel
Cells(11, 3) = "Индексы повторяющихся елементов"
End Sub



1



23 / 23 / 12

Регистрация: 13.09.2010

Сообщений: 88

26.09.2011, 19:37

 [ТС]

8

А чтобы вывести только искомые индексы всех 5 как это сделать?



0



19vitek

730 / 406 / 95

Регистрация: 19.12.2010

Сообщений: 756

26.09.2011, 19:47

9

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub n()
For i = 1 To 10
Cells(i, 2) = Application.WorksheetFunction.CountIf([a1:a10], Cells(i, 1))
Next i
For Each cel In [b1:b10]
If cel.Value > 1 Then
Cells(1, 5) = "Цифра " & Cells(cel.Row, 1) & " стоит первой в массиве "
Cells(2, 5) = "и повторяется " & Cells(cel.Row, 2) & " раз(a)"
Cells(3, 5) = "ее индекс в массиве " & cel.Row
temp = Cells(cel.Row, 1)
Exit For
End If
Next cel
[c:c].Clear
For Each cel In [b1:b10]
If cel.Value > 1 And Cells(cel.Row, 1) = temp Then Cells(cel.Row, 3) = cel.Row
Next cel
Cells(11, 3) = "Индексы цифры " & temp
End Sub



1



23 / 23 / 12

Регистрация: 13.09.2010

Сообщений: 88

26.09.2011, 20:00

 [ТС]

10

Не обижайтесь пожалуйста, но меня просто интересует индекс именно второй цифры 5, как его программно запомнить, он мне нужен будет для расчетов….



0



19vitek

730 / 406 / 95

Регистрация: 19.12.2010

Сообщений: 756

26.09.2011, 20:17

11

ИМЕННО ВТОРОЙ ИЛИ ПОСЛЕДНЕЙ?

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

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub n()
For i = 1 To 10
Cells(i, 2) = Application.WorksheetFunction.CountIf([a1:a10], Cells(i, 1))
Next i
For Each cel In [b1:b10]
If cel.Value > 1 Then
Cells(1, 5) = "Цифра " & Cells(cel.Row, 1) & " стоит первой в массиве "
Cells(2, 5) = "и повторяется " & Cells(cel.Row, 2) & " раз(a)"
Cells(3, 5) = "ее индекс в массиве " & cel.Row
temp = Cells(cel.Row, 1)
Exit For
End If
Next cel
[c:c].Clear
For Each cel In [b1:b10]
If cel.Value > 1 And Cells(cel.Row, 1) = temp Then
Cells(cel.Row, 3) = cel.Row
k = k + 1
End If
If k = 2 Then
ind = cel.Row
Exit For
End If
Next cel
Cells(11, 3) = "Второй индекс цифры " & temp & "=" & ind
End Sub



1



23 / 23 / 12

Регистрация: 13.09.2010

Сообщений: 88

26.09.2011, 20:57

 [ТС]

12

Именно второй

Добавлено через 1 минуту
Большое Вам спасибо за помощь и терпение!!!



0



Skip to content

На чтение 3 мин. Просмотров 4.1k.

Что делает макрос: Всегда хотел выделить значения дубликатов в диапазоне. Макрос в этом разделе делает именно это. Есть много ручных способов найти и выделить дубликаты — способы, включающие формулы, условное форматирование, сортировку и т.д. Тем не менее, все эти методы требуют ручной настройки и определенного уровня обслуживания по мере изменения данных.
Этот макрос упрощает задачу, что позволяет найти и выделить дубликаты в ваших данных с помощью щелчка мыши.

Содержание

  1. Как макрос работает
  2. Код макроса
  3. Как этот код работает
  4. Как использовать

Как макрос работает

Этот макрос перечисляет ячейки в целевом диапазоне, используя оператор For Each, чтобы активировать каждую ячейку по одной за раз. Затем мы используем функцию СЧЕТЕСЛИ, чтобы подсчитать, сколько раз значение в активной ячейке находится в выбранном
диапазоне. Если это число больше единицы, то формат ячейки — желтого цвета.

Код макроса

Sub VidelitDublikati()
'Шаг 1: Объявляем переменные
Dim MyRange As Range
Dim MyCell As Range
'Шаг 2: определяем целевой диапазон
Set MyRange = Selection
'Шаг 3: запускаем цикл через диапазон
For Each MyCell In MyRange
'Шаг 4: Убедить, что ячейка имеет форматирование текста
If WorksheetFunction.CountIf(MyRange, MyCell.Value) > 1 Then
MyCell.Interior.ColorIndex = 36
End If
'Шаг 5: Получаем следующую ячейку в диапазоне
Next MyCell
End Sub

Как этот код работает

  1. На шаге 1 объявляются две переменные объекта Range, одна из которых называется MyRange для хранения всей цели диапазона, а другая называется MyCell для хранения каждой ячейки в диапазоне.
  2. Шаг 2 заполняет переменную MyRange целевым диапазоном. В этом примере мы используем выбранный диапазон — диапазон, который был выбран в электронной таблице. Вы можете легко установить переменную MyRange для определенного диапазона, например Range («A1: Z100»). Кроме того, если ваша цель — именованный диапазон, вы можете просто ввести его имя: Range («MyNamedRange»).
  3. Шаг 3 макрос начинает проходить по каждой ячейке в целевом диапазоне, активируя каждую ячейку.
  4. Объект WorksheetFunction позволяет нам запускать многие из Excel функции электронных таблиц в VBA. Шаг 4 использует объект WorksheetFunction для запуска Функция СЧЕТЕСЛИ в VBA.
    В этом случае мы рассчитываем, сколько раз значение активной ячейки (MyCell.Value) найдено в заданном диапазоне (MyRange). Если выражение СЧЕТЕСЛИ оценивается больше 1, макрос изменяет цвет ячейки.
  5. Шаг 5 возвращается к следующей ячейке. После активации всех ячеек в целевом диапазоне макрос заканчивается.

Как использовать

Для реализации этого макроса, вы можете скопировать и вставить его в стандартный модуль:

  1. Активируйте редактор Visual Basic, нажав ALT + F11.
  2. Щелкните правой кнопкой мыши имя проекта / рабочей книги в окне проекта.
  3. Выберите Insert➜Module.
  4. Введите или вставьте код.

Понравилась статья? Поделить с друзьями:
  • Vba excel поиск по части слова
  • Vba excel поиск по тексту в word
  • Vba excel поиск по всем файлам
  • Vba excel поиск по textbox
  • Vba excel поиск нескольких значений