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

grooogler

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

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

очень нужен один макрос.    

   Офис 2007 (База.xlsx)    
В ней около 12 Листов, названия листов произвольные. (в каждом листе заполнено около 1000 строк)    
В принципе задача такая — Найти повторения значений ячеек в столбцах ‘B’ всех листов.    

   Как нужно чтоб всё было — Открываем нужный лист, например List10, выделяем ячейки в столбце ‘B’. Запускаем макрос, он пробегается по всем другим листам ища совпадения в столбцах B. Если какая-то ячейка в нашем List10 в столбце B совпадает с ячейкой например в листе List20 (тоже в столбце B), то эту ячейку в List10 мы выделяем красным цветом. Всё.

Пробуйте  

  Sub grooogler()  
Dim sh As Worksheet  
For Each sh In Worksheets  
   If Not sh Is ActiveSheet Then  
       If Not sh.Columns(2).Find(ActiveCell, , xlValues, xlWhole) Is Nothing Then  
           ActiveCell.Interior.Color = vbRed  
           Exit Sub  
       End If  
   End If  
Next  
End Sub

тестирую.  
1. как я понял находит только одно совпадение и прекращает искать. а нужно все выделенные прочекать…  
2. если выделяю ячейку которая уже красная — не ищет

grooogler

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

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

{quote}{post}тестирую.  
1. как я понял находит только одно совпадение и прекращает искать. а нужно все выделенные прочекать…{/post}{/quote}  
Прекращает искать при первом найденном совпадении. Дальше искать нет смысла — ячейка от этого краснее не станет. А ищет совпадение действительно только одной ячейки, той которая активна. Если надо по всем в выделенном диапазоне, то еще один цикл надо:  
Sub ColorRange()  
 Dim iCell As Range  
 For Each iCell In Selection.Cells  
   iCell.Select  
   grooogler  
 Next  
End Sub  

  или так, чтобы проверить все ячейки в столбце 2  
Sub ColorColumn()  
 i = 1  
 j = 2   ‘второй столбец  
 Do Until Cells(i, j) = «» ‘До первой пустой ячейки  
   Cells(i, j).Select  
   ActiveCell.Interior.Pattern = False  
   grooogler  
   i = i + 1  
 Loop  
End Sub  

  если в столбце могут быть пустые ячейки, а надо проверять и дальше — поменяйте строку  Do Until Cells(i, j) = «»  на  Do Until i=1000 ‘1000 — кол-во проверяемых строк.  

  {quote}{post}  
2. если выделяю ячейку которая уже красная — не ищет{/post}{/quote}  
Ищет, только вы не видите результата, как была красная, так и осталась.  
Чтобы снимать выделение перед поиском (вдуг дубликатов уже нет) вставьте строку ActiveCell.Interior.Pattern = False (см 2-й пример)

макросы привязаны к    
Ctrl-q — раскрашивание ячеек в выделенном диапазоне  
Ctrl-w — раскрашивание ячеек во 2 столбце, независимо от выделенного диапазона и активной ячейки

grooogler

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

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

{quote}если в столбце могут быть пустые ячейки, а надо проверять и дальше — поменяйте строку Do Until Cells(i, j) = «» на Do Until i=1000 ‘1000 — кол-во проверяемых строк.{/quote}  
Да вроде в твоём примере и он и так находит ячейки которые идут после пустых строк  

  {quote}макросы привязаны к    
Ctrl-q — раскрашивание ячеек в выделенном диапазоне  
Ctrl-w — раскрашивание ячеек во 2 столбце, независимо от выделенного диапазона и активной ячейки{/quote}  
вот тут не понял. это к чему?  

    В принципе постестил так… вроде подходит ColorColumn. Но он чекает все ячейки открытого листа… а можно ли всё таки так, чтобы он искал только дубли для выделенных ячеек?  

  ColorRange что-то я тестю, тестю… не вижу чтобы чем-то отличался от первоначального варианта.так-же ищет дубли только для одной активной ячейки на которую щёлкал мышкой в начале выделения…  

  {quote}Чтобы снимать выделение перед поиском (вдуг дубликатов уже нет) вставьте строку ActiveCell.Interior.Pattern = False (см 2-й пример){/quote}  
да. спасибо.

Hugo

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

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

Я бы такой алгоритм применил —    
1. цикл по листам (исключая текущий)  
2. UsedRange столбца B  в массив, его в словарь. Словарь один на все листы.  
3. Работа с выделенным (если много, то в массив, если нет  — то прямо с листа можно) — сверяемся с словарём и красим.  

  Так будет быстро, т.к. переборов данных листов = количеству_листов, а не количество_выделенных_ячеек * количество_листов.

nerv

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

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

Почти тоже самое, о чем говорил Hugo  

  Sub io()  
Dim x, objSheet As Object, objRange As Object, objDict As Object  
Set objRange = Selection  
Set objDict = CreateObject(«Scripting.Dictionary»)  
For Each x In objRange.Cells  
   If x <> «» Then objDict.Item(CStr(x)) = x  
Next  
For Each objSheet In Worksheets  
   If Not objSheet Is ActiveSheet Then  
       For Each x In objSheet.Range(objRange.Address).Cells  
           If objDict.Item(CStr(x)) Then x.Interior.ColorIndex = 6  
       Next  
   End If  
Next  
End Sub  

  p.s.: выделять ТОЛЬКО ячейки

grooogler

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

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

ничего не понял что писал Hugo если честно)  

  но первые варианты мне как-то больше понравились. точнее — они работают. если бы ещё на вопросы ответить которые я писал и подкорректировать что говорил…  

  >nerv  
ну, как то мягко говоря не пашит. не понятно почему, что-то находит что-то нет. а если и находит, то выделяет не повторяющуюся ячейку из тех что я выделил, а в другом месте — где нашелся дубль. я должно быть необорот) ну и собственно… что главное что собственно и не очень то пашит

Hugo

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

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

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

  Sub io2()  
Dim x, objSheet As Object, objRange As Object, objDict As Object, i As Long  
Set objRange = Selection  
Set objDict = CreateObject(«Scripting.Dictionary»)  
For Each x In objRange.Cells  
i = i + 1  
If x <> «» Then objDict.Item(CStr(x)) = i  
Next  
For Each objSheet In Worksheets  
If Not objSheet Is ActiveSheet Then  
For Each x In objSheet.UsedRange.Columns(2).Cells  
If objDict.Item(CStr(x)) Then objRange(objDict.Item(CStr(x))).Interior.ColorIndex = 6  
Next  
End If  
Next  
End Sub  

  Sub io3()  
Dim x, objSheet As Object, objRange As Object, objDict As Object  
Set objRange = Selection  
Set objDict = CreateObject(«Scripting.Dictionary»)  

  For Each objSheet In Worksheets  
If Not objSheet Is ActiveSheet Then  
For Each x In objSheet.UsedRange.Columns(2).Cells  
If x <> «» Then objDict.Item(CStr(x)) = x  
Next  
End If  
N

Hugo

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

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

упс, недокопипастил  

  Sub io3()  
Dim x, objSheet As Object, objRange As Object, objDict As Object  
Set objRange = Selection  
Set objDict = CreateObject(«Scripting.Dictionary»)  

  For Each objSheet In Worksheets  
If Not objSheet Is ActiveSheet Then  
For Each x In objSheet.UsedRange.Columns(2).Cells  
If x <> «» Then objDict.Item(CStr(x)) = x  
Next  
End If  
Next  

  For Each x In objRange.Cells  
If objDict.Item(CStr(x)) Then x.Interior.ColorIndex = 6  
Next  

  End Sub

Hugo

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

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

Проверку по словарю можно так написать — так понятнее, и вероятно правильнее:  
If objDict.exists(CStr(x)) Then x.Interior.ColorIndex = 6

Hugo

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

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

Так подшлифовал (вроде даже комментарии не нужны):  

  Sub io4()  
Dim x, objSheet As Object  

  With CreateObject(«Scripting.Dictionary»)  

  For Each objSheet In Worksheets  
If Not objSheet Is ActiveSheet Then  
For Each x In objSheet.UsedRange.Columns(2).Cells  
If CStr(x.Value) <> «» Then .Item(CStr(x.Value)) = 1  
Next  
End If  
Next  

  For Each x In Selection.Cells  
If .exists(CStr(x.Value)) Then x.Interior.ColorIndex = 3  
Next  

  End With  

  End Sub

nerv

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

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

nerv

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

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

{quote}{login=Hugo}{date=02.08.2011 12:08}{thema=}{post}Проверку по словарю можно так написать — так понятнее, и вероятно правильнее:  
If objDict.exists(CStr(x)) Then x.Interior.ColorIndex = 6{/post}{/quote}ну да)

Hugo

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

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

Такой вариант с использованием массивов.  
Работает быстро, но выделять нужно столбик (не несколько столбцов), т.к. порядок перебора массива не сопадает с порядком перебора Selection, и поэтому Selection(i) будет врать, если выделено несколько строк в нескольких столбцах.  

  Sub io5()  
Dim a, x, objSheet As Object, i&  

  With CreateObject(«Scripting.Dictionary»)  

  For Each objSheet In Worksheets  
If Not objSheet Is ActiveSheet Then  
a = objSheet.UsedRange.Columns(2).Value  
For Each x In a  
If x <> «» Then .Item(CStr(x)) = 1  
Next  
End If  
Next  

  a = Selection.Value  
For Each x In a  
i = i + 1  
If .exists(CStr(x)) Then Selection(i).Interior.ColorIndex = 3  
Next  

  End With  
End Sub

Hugo

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

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

{quote}{login=nerv}{date=02.08.2011 12:24}{thema=}{post}так?{/post}{/quote}  
Красиво, лаконично. Без словарей и массивов  
Только зачем перебирать остальные листы, если 11111 уже покрашено?  
Исправишь — уже не так красиво будет  
Кстати, как исправлять будешь? У меня есть мысль, но не скажу

Hugo

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

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

Ладно, покажу мысль. Думал, другой вариант посмотреть — вдруг что-то короче придумается…  
Листы перебираются всегда, но их содержимое только до тех пор, пока ячейка не покрашена:  

  Sub io()  
Dim x, i, objSheet As Object, flag As Boolean  
For Each x In Selection.Cells  
flag = True  
   For Each objSheet In Worksheets  
   If flag Then  
       If Not objSheet Is ActiveSheet Then  
           For Each i In objSheet.UsedRange.Columns(Selection.Column).Cells  
               If x = i Then x.Interior.ColorIndex = 6: flag = False: Exit For  
           Next  
       End If  
   End If  
   Next  
Next  
End Sub  

  Но на словарях/массивах конечно быстрее — там по одному перебору всех диапазонов происходит (т.е. один раз второй столбец каждого другого листа, потом один раз Selection), а тут на каждую ячейку Selection перебираются все ячейки колонки выделения всех листов, пока не будет совпадения. Т.е. если Selection например 1000 ячеек и в книге 11 листов, то переберутся столбцы выделенного столбца 10000 листов, и чем меньше будет совпадений, тем дольше процесс.

nerv

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

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

Hugo, я бы ответил раньше, но обед … ням : )  

  Привет Ассемблер, Финт ушами)  
Sub io()  
Dim x, objSheet As Object  
For Each x In Selection.Cells  
   For Each objSheet In Worksheets  
       If Not objSheet Is ActiveSheet Then  
           For Each i In objSheet.UsedRange.Columns(Selection.Column).Cells  
               If x = i Then x.Interior.ColorIndex = 6: GoTo L1  
           Next  
       End If  
   Next  
L1: Next  
End Sub

Hugo

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

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

я ещё не обедал  
Говорят, GoTo не по феншую…  
Но тут похоже на феншуй

nerv

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

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

Hugo: «Говорят, GoTo не по феншую…»  

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

GIG_ant

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

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

{quote}{login=nerv}{date=02.08.2011 03:02}{thema=}{post}  
Все зависит от обстоятельств. В данном случае, те кто говорил, ошибались){/post}{/quote}  

  Может я ошибаюсь в предполжении, но что мешает, в вашем случае: Goto — заменить на Exit For и убрать метку L1.

GIG_ant

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

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

Не усмотрел еще одно Next, вопрос снимаю ))

Hugo

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

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

GIG_ant, так уже было — мне не понравилось  
А если серъёзно  — так выйдем из цикла по текущему листу. Но если ещё 99 листов не просмотрено?

Hugo

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

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

Поздно, я уже ответ написал

grooogler

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

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

так, а давайте всё таки доделаем всё это в практическом плане а?))  

  пробую  

  Sub io()  
Dim x, i, objSheet As Object, flag As Boolean  
For Each x In Selection.Cells  
flag = True  
For Each objSheet In Worksheets  
If flag Then  
If Not objSheet Is ActiveSheet Then  
For Each i In objSheet.UsedRange.Columns(Selection.Column).Cells  
If x = i Then x.Interior.ColorIndex = 6: flag = False: Exit For  
Next  
End If  
End If  
Next  
Next  
End Sub  

  вот этот. остальные что-то не пашут.  

  1. как в этот код добавить чтобы он перед поиском — убирал Цвет ячеек с выделенных акков?  
2. чтобы дубли пустых ячеек не искал (если выделена пустая ячейка)  
3. красный цвет чтоб был ане жёлтый.

nilem

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

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

Для примера:  

  Sub ioio()  
If IsEmpty(Selection) Then MsgBox «Пустая ячейка», 64: Exit Sub  
If Selection.Columns.Count > 1 Then MsgBox «Выделено более 2 столбцов», 64: Exit Sub  
Dim r As Range, i As Range, wsh As Worksheet, clmn As Long  
clmn = Selection.Column: If clmn <> 2 Then MsgBox «Выделяем только 2-й столбец», 64: Exit Sub  
ActiveSheet.Columns(clmn).Interior.Color = xlNone  
For Each wsh In Worksheets  
   If Not wsh Is ActiveSheet Then  
       For Each i In wsh.UsedRange.Columns(2).Cells  
           For Each r In Selection.Cells  
               If Len® Then If r = i Then r.Interior.Color = vbYellow  
           Next  
       Next  
   End If  
Next  
End Sub

Hugo

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

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

Как это не пашут?  
А вот этот, на словаре и массивах, проверяли?

grooogler

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

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

#30

02.08.2011 23:05:02

nilem  
спасибо вроде всё как надо.  
такая только деталь… если я щёлкаю на заголовок столбца B, то соответственно выделяются все ячейки столбца… до самого низа на тысячи строк… а у меня заполнено только строки до 800-й… ну и когда я запускают поиск… макрос ищет дубли для всех этих тысяч строк… а точнее — попросту виснет.  

  можно сделать какую-нибудь проверку… примерно таким образом — если выделена пустая ячейка — то для неё дубли не ищутся (как сейчас реализовано), и мы идём дальше… но, дальше мы в таком случае идём только в том случае если далее есть не пустые выделенные ячейки.  

  вот примерно таким образом. доходим до пустой йчейки, проверяем есть ли за неё ещё что-то не пустое, и если далее всё пусто — останавливаемся