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

[zontique]

Здравствуйте,

помогите пожалуйста составить макрос для сравнение столбцов с последующим копированием совпадений на новый лист.

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

Надеюсь, что смог все объяснить и буду благодарен вам если вы поможете мне в этом вопросе.


--------- примечание модератора - вдруг кому пригодится --------------

Надстройка LOOKUP предназначена для сравнения и подстановки значений в таблицах Excel.

Если вам надо сравнить 2 таблицы (по одному столбцу, или по нескольким),
и для совпадающих строк скопировать значения выбранных столбцов из одной таблицы в другую,
надстройка «Lookup» поможет сделать это нажатием одной кнопки.

В настройках программы можно задать:

• где искать сравниваемые файлы (использовать уже открытый файл, загружать файл по заданному пути, или же выводить диалоговое окно выбора файла)
• с каких листов брать данные (варианты: активный лист, лист с заданным номером или названием)
• какие столбцы сравнивать (можно задать несколько столбцов)
• значения каких столбцов надо копировать в найденные строки (также можно указать несколько столбцов)

Скачать надстройку для сравнения таблиц Excel и копирования данных из одинаковых строк

[Hugo121]

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

Макросом сделать несложно - но нужен пример данных. От этого зависит вариант решения.

[IgorGO]

вот макрос, который решит задачу, как я ее понял (не факт что я угадал, понятие "сравнить данные листа 1 и 2" четко не определено)

Sub Copy2Last()
  Dim r1 As Long, r2 As Long
  With Worksheets.Add(after:=Worksheets(Worksheets.Count))
    For r1 = 1 To Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
      If Worksheets(1).Cells(r1, 1) = Worksheets(2).Cells(r1, 1) Then
        r2 = r2 + 1
        Worksheets(2).Rows(r1).Copy Destination:=.Cells(r2, 1)
      End If
    Next
    .Activate
  End With
End Sub

[Hugo121]

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

[zontique]

К сожалению сам файл я выложить не могу, но вот попытался объяснить, что мне нужно во вложении.
Спасибо, что откликнулись.

[Hugo121]

Я угадал точнее

Sub tt()
    Dim a(), i&, ii&

    Application.ScreenUpdating = False

    Worksheets(3).UsedRange.Clear

    With CreateObject("Scripting.Dictionary")
        a = Worksheets(1).[a1].CurrentRegion.Value
        For i = 1 To UBound(a): .Item(a(i, 1)) = 0&: Next
        a = Worksheets(2).[a1].CurrentRegion.Value
        For i = 1 To UBound(a)
            If .exists(a(i, 1)) Then
                ii = ii + 1: a(ii, 1) = a(i, 1): a(ii, 2) = a(i, 2)
            End If
        Next
        Worksheets(3).[a1].Resize(ii, 2) = a
    End With

    Application.ScreenUpdating = True
End Sub

Все листы должны быть как в примере - код писался именно под такой файл.
Рамку рисовать не стал - если очень нужно, то можно добавить.

[zontique]

Спасибо за макрос, а можно сделать его более универсальным? чтоб листы были не только как в примере?

[Hugo121]

Почти абсолютно универсально

Sub ttt()
    Dim r As Range, a(), i&, ii&

    On Error Resume Next
    With CreateObject("Scripting.Dictionary")

        Set r = Application.InputBox(Prompt:="Выделите первый диапазон для сравнения (1 столбец)", Type:=8)
        If r Is Nothing Then Exit Sub
        a = r.Value
        For i = 1 To UBound(a): .Item(a(i, 1)) = 0&: Next

        Set r = Application.InputBox(Prompt:="Выделите второй диапазон для сравнения (2 смежных столбца!)", Type:=8)
        If r Is Nothing Then Exit Sub
        a = r.Value
        For i = 1 To UBound(a)
            If .exists(a(i, 1)) Then
                ii = ii + 1: a(ii, 1) = a(i, 1): a(ii, 2) = a(i, 2)
            End If
        Next

    End With

    If ii > 0 Then Workbooks.Add(1).Sheets(1).[a1].Resize(ii, 2) = a

End Sub

[zontique]

Спасибо большое.

[zontique]

Без вашей помощи мне не обойтись, помогите пожалуйста сделать так, чтоб он брал всю строку, а не только 2 столбца.