Сравнение двух столбцов на одном листе

[jm2m]

Необходимо провести сравнение столбца А (30 тыс строк) и столбца С (500 строк ), все совпадения вывести в столбец D и покрасить все совпадения по столбцам А и С
Пример в архиве
спасибо

[Hugo121]

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

Sub tt()
    Dim c As Range, cc As Range
    With ActiveSheet
        For Each c In Intersect(.UsedRange, .Columns(1)).Cells
            For Each cc In Intersect(.UsedRange, .Columns(3)).Cells
                If Len(c.Value) Then
                    If c.Value = cc.Value Then
                        c.Interior.Color = vbYellow: cc.Interior.Color = vbYellow
                        cc.Copy cc.Offset(, 1)
                    End If: End If
            Next: Next
    End With
End Sub

Сразу говорю - быстро не будет. Ну как просили (т.е. не просили...). у меня тут тоже необходимо...

[Serge 007]

Сообщение от Hugo121

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

Верно
Но формула работает быстро

[Hugo121]

Вообще этот мой код можно ускорить, кое-что перевернув и поменяв местами. И отключив.

[jm2m]

Хьюго, раскраска так для баловства, да...надолго повисла...
Серж, я в экселе и в програмерских делах ноль на палочке, напиши в формуле пож-та сравнение 30.000 строк столбца А с 1.000(тыс) строк столбца С, вывод совпадений в D .... вставлять формулу надо для столбика D , все верно?
Помогите ламеру :-)

[Serge 007]

Тут не надо быть программистом, достаточно простой логики...
Просто замените все ссылки A$5 в формуле на A$30000
Как быстро заполнить 30 тысяч ячеек читайте здесь

[Hugo121]

Ладно, раз уж просьба прозвучала...

Sub compare()
    Dim tm!: tm = Timer
    Dim a(), i&, ii&

    With Sheets(1)    'используется номер листа
        a = Range(.[c1], .Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row)).Value

        ReDim b(1 To UBound(a), 1 To 1)

        With CreateObject("Scripting.Dictionary")

            For i = 1 To UBound(a)
                .Item(a(i, 1)) = 0&
            Next

            For i = 1 To UBound(a)
                If Len(a(i, 3)) Then
                    If .exists(a(i, 3)) Then
                        ii = ii + 1
                        b(ii, 1) = a(i, 3)
                    End If
                End If
            Next
        End With
        If ii > 0 Then .[d1].Resize(ii, 1) = b
    End With

    MsgBox "Выполнено за " & Format((Timer - tm) / 24 / 60 / 60, "nn:ss") & " сек."
End Sub

Будет мнгновенно, но без покраски и копирования напротив совпавших (хотя это можно без потерь скорости добавить) - просто соберёт всех в кучку. На повтор повторов отсева нет!
Можно ещё чуть ускорить - определить строку третьего столбца, до которой перебирать массив. Но т.к. это всего лишь доля секунды экономии - поленился.

[jm2m]

заменил AS5 на AS25000 везде) не ищет , только по первой ячейке С1
Макрос тоже прогонял, ничего не получается .
Господа ткните пальцем - сделай так и так.
Преогромное спасибо.
Во вложении пример

[jm2m]

прошу прощения...в примере результат конечно должен быть в столбике D

[Hugo121]

Ну конечно...
В коде первая действующая строка какая?

With Sheets(1)