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

[gladius13]

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

Сам в программировании не силен, поэтому прошу помощи со следующей задачей:
1. Нужно сравнить два столбца данных с различным количеством строк и вывести одинаковые значения второго столбца напротив первого столбца. При этом необходимо чтобы строки в первом столбце не менялись местами.
2. Возможно ли привязать ко 2-му столбцу еще несколько столбцов с данными (например цена, количество), чтобы их строки вместе со строками 2-го столбца выстраивались напротив одинаковых значений. Например:

A - A - 5 - 4р.

В - B - 3 - 5р.

F - F - 1 - 6р.

Есть макрос, который сравнивает содержимое 2-х соседних столбцов на одинаковые значения и выводит на отдельном листе результат, сортируя одинаковые значения напротив друг друга и выделяя их цветом. Но при этом порядок значений в 1 столбце меняется.
Вот сам макрос:
_
Sub Main()

Dim i As Long, j As Long, a(), b(), x As Range, y As Range
Application.ScreenUpdating = False: Sheets(2).Activate: Cells.Delete
Sheets(1).Columns(1).Copy [A1]: Sheets(1).Columns(2).Copy [B1]: Columns(1).Copy [C1]
Range([B1], Cells(Rows.Count, 2).End(xlUp)).Copy Cells(Rows.Count, 3).End(xlUp).Offset(1)
[C:C].Sort Key1:=[C1], Order1:=xlAscending, Header:=xlGuess
a = Range([C1], Cells(Rows.Count, 3).End(xlUp)).Value: ReDim b(1 To UBound(a, 1), 1 To 2): i = 1: j = 1
Do
Set x = Columns("A").Find(a(i, 1))
If Not x Is Nothing Then
b(j, 1) = a(i, 1): x.Value = ""
End If
Set y = Columns("B").Find(a(i, 1))
If Not y Is Nothing Then
b(j, 2) = a(i, 1): y.Value = ""
End If
If Not x Is Nothing And Not y Is Nothing Then i = i + 2 Else i = i + 1
j = j + 1
Loop While i <= UBound(b, 1)
Range([D1], Cells(UBound(b, 1), 5)).Value = b: [A:C].Delete
For i = 1 To ActiveSheet.UsedRange.Rows.Count
If Cells(i, 1) = Cells(i, 2) Then Range(Cells(i, 1), Cells(i, 2)).Interior.ColorIndex = 6
Next
With ActiveSheet.UsedRange
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyl e = xlContinuous
.Borders(xlInsideHorizontal).LineSt yle = xlContinuous
End With

End Sub
_

Возможно ли доработать данный макрос так, чтобы он осуществлял 2 описанные выше задачи? Или может быть есть какие-либо другие решения?

Прикладываю файл содержащий данный макрос и пример.



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

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

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

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

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

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

[Hugo121]

Т.е. первый столбец остаётся как есть, а второй со всеми своими "парами" (кстати, почему их нет?) распределяется рядом с первым? "Незадействованные" номера выкидываем?

Тогда заполните чем-нибудь столбцы C и D и выполните макрос:

Option Explicit


Sub compare()
    Dim a(), b(), c(), t&, x As Byte, iLastrow As Long, i As Long

    With Sheets(1)
        iLastrow = .Cells(Rows.Count, 1).End(xlUp).Row
        a = Range(.[A1], .Range("A" & iLastrow)).Value
        iLastrow = .Cells(Rows.Count, 2).End(xlUp).Row
        b = Range(.[D1], .Range("B" & iLastrow)).Value

        ReDim c(1 To UBound(a), 1 To 3)

        With CreateObject("Scripting.Dictionary")

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

            For i = 1 To UBound(b)
                If .exists(b(i, 1)) Then
                    t = .Item(b(i, 1))
                    For x = 1 To 3: c(t, x) = b(i, x): Next
                End If
            Next
        End With

        .[F1].Resize(UBound(c), 3) = c
        .Activate
    End With

End Sub

Выгрузка для сравнения в [F1], но можно выгружать и в [B1] - массив затрёт все данные рядом с данными столбца A.

[DiemonStar]

Выгрузка для сравнения в [F1], но можно выгружать и в [B1] - массив затрёт все данные рядом с данными столбца A.

правильнее перед выгрузкой сделать

.[B:D].ClearContents

иначе внизу останется куча мусора...

[Hugo121]

В этом конкретном примере не останется.
Если всегда первый столбец "выше" второго - то и никогда не останется. Поэтому зачем делать лишнюю работу?

[DiemonStar]

Если всегда первый столбец "выше" второго

с конечными пользователями нередко так не получается. так что это скорее один из элементов "защиты от дурака"

[gladius13]

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

Т.е. первый столбец остаётся как есть, а второй со всеми своими "парами" (кстати, почему их нет?) распределяется рядом с первым? "Незадействованные" номера выкидываем?

Тогда заполните чем-нибудь столбцы C и D и выполните макрос:

Option Explicit


Sub compare()
    Dim a(), b(), c(), t&, x As Byte, iLastrow As Long, i As Long

    With Sheets(1)
        iLastrow = .Cells(Rows.Count, 1).End(xlUp).Row
        a = Range(.[A1], .Range("A" & iLastrow)).Value
        iLastrow = .Cells(Rows.Count, 2).End(xlUp).Row
        b = Range(.[D1], .Range("B" & iLastrow)).Value

        ReDim c(1 To UBound(a), 1 To 3)

        With CreateObject("Scripting.Dictionary")

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

            For i = 1 To UBound(b)
                If .exists(b(i, 1)) Then
                    t = .Item(b(i, 1))
                    For x = 1 To 3: c(t, x) = b(i, x): Next
                End If
            Next
        End With

        .[F1].Resize(UBound(c), 3) = c
        .Activate
    End With

End Sub

Выгрузка для сравнения в [F1], но можно выгружать и в [B1] - массив затрёт все данные рядом с данными столбца A.

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

Макрос вроде работает как нужно! Спасибо!
Нельзя еще сделать чтобы второй столбец захватывал с собой при распределении больше 2 столбцов (хотя бы 4) и выводил результат на отдельном листе?

[Hugo121]

Можно.
меняйте тут:

ReDim c(1 To UBound(a), 1 To 3)

                      For x = 1 To 3: c(t, x) = b(i, x): Next

а тут допишите впереди имя листа:

.[F1].Resize(UBound(c), 3) = c

Только не понял - зачем на другом листе "дырявый" второй столбец?
Не проще ли всё проделывать на копии?

[gladius13]

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

Можно.
меняйте тут:

ReDim c(1 To UBound(a), 1 To 3)

                      For x = 1 To 3: c(t, x) = b(i, x): Next

а тут допишите впереди имя листа:

.[F1].Resize(UBound(c), 3) = c

Только не понял - зачем на другом листе "дырявый" второй столбец?
Не проще ли всё проделывать на копии?

Спасибо. Наверное проще, просто для удобства хотелось бы получать результат на отдельном листе.

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

[Hugo121]

Можно.
Но вникать сейчас некогда.
Что-то вроде

For x = 1 To 3: c(t, x) = c(t, x) + b(i, x): Next

посмотрите по месту.

[gladius13]

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

Можно.
Но вникать сейчас некогда.
Что-то вроде

For x = 1 To 3: c(t, x) = c(t, x) + b(i, x): Next

посмотрите по месту.

Работает, но при использовании этого кода кроме значений в смежных столбцах суммируются и значения столбца, в котором выстраиваются одинаковые значения. Например, если значение "3" встречается два раза, то макос ставит 6 и далее суммы по смежным столбцам( а нужно чтобы было 3 и суммы по смежным столбцам).