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

{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-й пример)

{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  
 
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.: выделять ТОЛЬКО ячейки

Я иначе думал - вроде в выделенном красить заказывали.  
Тогда такие варианты кода 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

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

так?

Такой вариант с использованием массивов.  
Работает быстро, но выделять нужно столбик (не несколько столбцов), т.к. порядок перебора массива не сопадает с порядком перебора 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

Ладно, покажу мысль. Думал, другой вариант посмотреть - вдруг что-то короче придумается...  
Листы перебираются всегда, но их содержимое только до тех пор, пока ячейка не покрашена:  
 
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 листов, и чем меньше будет совпадений, тем дольше процесс.

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

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

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

так, а давайте всё таки доделаем всё это в практическом плане а?))  
 
пробую  
 
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. красный цвет чтоб был ане жёлтый.

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