Макрос для сравнения нескольких столбцов таблицы - Мир MS Excel

Регистрация

Напомнить пароль

= Мир MS Excel/Макрос для сравнения нескольких столбцов таблицы - Мир MS Excel

Старая форма входа

Страница 1 из 2 1 2 »
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос для сравнения нескольких столбцов таблицы (Макросы/Sub)

Макрос для сравнения нескольких столбцов таблицы

Дата: Среда, 09.12.2015, 11:02 | Сообщение № 1

Группа: Пользователи

Ранг: Прохожий

Сообщений: 8

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Добрый день! Нужна помощь в следующем вопросе. Есть две таблицы П и Д со столбцами Имя клиента и Адрес. Необходимо сравнить эти две таблицы, то есть найти тех клиентов которые есть в таблице П, но нет в таблице Д. Как результат после сравнения создать две новые таблицы. В первую таблицу перенести различия (имя клиента и адрес), а во вторую совпадения (имя клиента и его адрес). В прикрепленном файле образец таблиц П и Д, в реале записей более 4000.
Заранее благодарна за помощь!

К сообщению приложен файл: 5903913.xls (30.0 Kb)

Ответить

Дата: Среда, 09.12.2015, 12:14 | Сообщение № 2

Группа: Проверенные

Ранг: Ветеран

Сообщений: 711

Репутация: 156 ±

Замечаний: 0% ±

Excel 2003

Цитата

сравнить эти две таблицы

Для размышления в файле создал лист Сравнение и макрос сравнения ФИО в двух столбцах.
Попробуйте использовать для своих задач. Удачи!

К сообщению приложен файл: 0190044.xls (42.5 Kb)

Ответить

Дата: Среда, 09.12.2015, 12:24 | Сообщение № 3

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация: 127 ±

Замечаний: 0% ±

Excel 2007, Excel 2013

AnnaKudrina, Странный у Вас пример. Если имена то совпадают... адреса совсем не совпадают... пример правильный? Я правильно понимаю, что имена то могут совпадать, а вот одинаковое ФИО на одном и том же адресе не повторяется?
У Вас по таблице: "П" 1-я позиция Абаканова Сатвальда Желгедовна адрес: 627554, Тюменская область, Абатский район п. Лесной ул. Южная, д. 054
По таблице :"Д" 1-я позиция "Абаканова Сатвальда Желгедовна" адрес: 627554, Тюменская область, Абатский район П Лесной Ул Ленина, д. 25 .
В итоге... совпадение должно быть именно только по именам? или по имя- адрес. Ведь на двух разных адресах, теоретически могут быть одинаковые имена... итог - нужно считать скок этих имён в 1 таблице и скок во второй... а какого именно из "одинаковых имён" нет в какой-то из таблиц, выяснить не получится.

Много чего не знаю!!!!

Ответить

Дата: Среда, 09.12.2015, 12:33 | Сообщение № 4

Группа: Пользователи

Ранг: Прохожий

Сообщений: 8

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Roman777, здравствуйте. Совпадения должно быть именно по именам и адресам. В итоге надо выбрать не повторяющихся клиентов с их адресами(по именам и адресам) из двух таблиц.

Сообщение отредактировал AnnaKudrina - Среда, 09.12.2015, 12:37

Ответить

Дата: Среда, 09.12.2015, 12:48 | Сообщение № 5

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация: 127 ±

Замечаний: 0% ±

Excel 2007, Excel 2013

AnnaKudrina, тогда в вашем примере:

Цитата Roman777, 09.12.2015 в 12:24, в сообщении № 3

У Вас по таблице: "П" 1-я позиция Абаканова Сатвальда Желгедовна адрес: 627554, Тюменская область, Абатский район п. Лесной ул. Южная, д. 054
По таблице :"Д" 1-я позиция "Абаканова Сатвальда Желгедовна" адрес: 627554, Тюменская область, Абатский район П Лесной Ул Ленина, д. 25 .

Это разные клиенты?

Много чего не знаю!!!!

Ответить

Дата: Среда, 09.12.2015, 13:02 | Сообщение № 6

Группа: Пользователи

Ранг: Прохожий

Сообщений: 8

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Roman777, да разные.

Ответить

Дата: Среда, 09.12.2015, 13:36 | Сообщение № 7

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация: 127 ±

Замечаний: 0% ±

Excel 2007, Excel 2013

AnnaKudrina, Муторно как-то, но вроде работает...

[vba]

Код

Sub Sravn()
Dim i As Long, i_n1 As Long, i_n2 As Long
Dim Tabl1() As String, Tabl2() As String, Sovp() As String, NeSovp() As String, k1 As Long, k2 As Long
Dim Obj1 As Object, Obj2 As Object, Key1 As String, Key2 As String, Obj3 As Object
Dim WS As Worksheet
Set Obj1 = CreateObject("Scripting.dictionary")
Set Obj2 = CreateObject("Scripting.dictionary")
Set Obj3 = CreateObject("Scripting.dictionary")
i_n1 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
ReDim Tabl1(2, i_n1)
For i = 1 To i_n1
Tabl1(1, i) = Trim(Worksheets(1).Cells(i, 1))
Tabl1(2, i) = Trim(Worksheets(1).Cells(i, 2))
Next i
i_n2 = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row
ReDim Tabl2(2, i_n2)
For i = 1 To i_n2
Tabl2(1, i) = Trim(Worksheets(2).Cells(i, 2))
Tabl2(2, i) = Trim(Worksheets(2).Cells(i, 3))
Next i
For i = 2 To i_n1
  Key1 = Tabl1(1, i) & Tabl1(2, i)
  If Not Obj1.exists(Key1) Then
    Obj1.Add Key1, Tabl1(2, i)
  End If
Next i
For i = 2 To i_n2
  Key2 = Tabl2(1, i) & Tabl2(2, i)
  If Not Obj2.exists(Key1) Then
    Obj2.Add Key2, Tabl2(2, i)
  End If
Next i
ReDim Sovp(2, 1)
ReDim NeSovp(2, 1)
Sovp(1, 1) = Tabl1(1, 1)
Sovp(2, 1) = Tabl1(2, 1)
NeSovp(1, 1) = Tabl1(1, 1)
NeSovp(2, 1) = Tabl1(2, 1)
k1 = 1
k2 = 1
For i = 2 To i_n1
  Key2 = Tabl1(1, i) & Tabl1(2, i)
  If Not Obj2.exists(Key2) Then
     k1 = k1 + 1
     ReDim Preserve NeSovp(2, UBound(NeSovp, 2) + 1)
     NeSovp(1, k1) = Tabl1(1, i)
     NeSovp(2, k1) = Tabl1(2, i)
  Else
     If Not Obj3.exists(Key2) Then
        Obj3.Add Key2, Tabl1(2, i)
        k2 = k2 + 1
        ReDim Preserve Sovp(2, UBound(Sovp, 2) + 1)
        Sovp(1, k2) = Tabl1(1, i)
        Sovp(2, k2) = Tabl1(2, i)
     End If
  End If
Next i
For i = 2 To i_n2
  Key1 = Tabl2(1, i) & Tabl2(2, i)
  If Not Obj1.exists(Key1) Then
     k1 = k1 + 1
     ReDim Preserve NeSovp(2, UBound(NeSovp, 2) + 1)
     NeSovp(1, k1) = Tabl2(1, i)
     NeSovp(2, k1) = Tabl2(2, i)
  Else
     If Not Obj3.exists(Key1) Then
        Obj3.Add Key1, Tabl2(2, i)
        k2 = k2 + 1
        ReDim Preserve Sovp(2, UBound(Sovp, 2) + 1)
        Sovp(1, k2) = Tabl2(1, i)
        Sovp(2, k2) = Tabl2(2, i)
     End If
  End If
Next i
On Error Resume Next
Set WS = Sheets("Совпали")
If WS Is Nothing Then
   Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Совпали"
Else
   WS.Cells.Clear
End If
Set WS = Nothing
On Error Resume Next
Set WS = Sheets("Несовпали")
If WS Is Nothing Then
   Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Несовпали"
Else
   WS.Cells.Clear
End If
For i = 1 To UBound(Sovp, 2)
  Worksheets("Совпали").Cells(i, 1) = Sovp(1, i)
  Worksheets("Совпали").Cells(i, 2) = Sovp(2, i)
Next i
For i = 1 To UBound(NeSovp, 2)
  Worksheets("Несовпали").Cells(i, 1) = NeSovp(1, i)
  Worksheets("Несовпали").Cells(i, 2) = NeSovp(2, i)
Next i
Worksheets(1).Range("A2:B2").Copy
With Worksheets("Совпали").UsedRange
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Rows.AutoFit
.Range(Cells(1, 1)).CurrentRegion.Sort Key1:=.Cells(1), Order1:=xlAscending, Orientation:=xlLeftToRight
End With
With Worksheets("Несовпали").UsedRange
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Rows.AutoFit
.Range(Cells(1, 1)).CurrentRegion.Sort Key1:=.Cells(1), Order1:=xlAscending, Orientation:=xlLeftToRight
End With
End Sub

[/vba]

AnnaKudrina, Муторно как-то, но вроде работает...

[vba]

Код

Sub Sravn()
Dim i As Long, i_n1 As Long, i_n2 As Long
Dim Tabl1() As String, Tabl2() As String, Sovp() As String, NeSovp() As String, k1 As Long, k2 As Long
Dim Obj1 As Object, Obj2 As Object, Key1 As String, Key2 As String, Obj3 As Object
Dim WS As Worksheet
Set Obj1 = CreateObject("Scripting.dictionary")
Set Obj2 = CreateObject("Scripting.dictionary")
Set Obj3 = CreateObject("Scripting.dictionary")
i_n1 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
ReDim Tabl1(2, i_n1)
For i = 1 To i_n1
Tabl1(1, i) = Trim(Worksheets(1).Cells(i, 1))
Tabl1(2, i) = Trim(Worksheets(1).Cells(i, 2))
Next i
i_n2 = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row
ReDim Tabl2(2, i_n2)
For i = 1 To i_n2
Tabl2(1, i) = Trim(Worksheets(2).Cells(i, 2))
Tabl2(2, i) = Trim(Worksheets(2).Cells(i, 3))
Next i
For i = 2 To i_n1
  Key1 = Tabl1(1, i) & Tabl1(2, i)
  If Not Obj1.exists(Key1) Then
    Obj1.Add Key1, Tabl1(2, i)
  End If
Next i
For i = 2 To i_n2
  Key2 = Tabl2(1, i) & Tabl2(2, i)
  If Not Obj2.exists(Key1) Then
    Obj2.Add Key2, Tabl2(2, i)
  End If
Next i
ReDim Sovp(2, 1)
ReDim NeSovp(2, 1)
Sovp(1, 1) = Tabl1(1, 1)
Sovp(2, 1) = Tabl1(2, 1)
NeSovp(1, 1) = Tabl1(1, 1)
NeSovp(2, 1) = Tabl1(2, 1)
k1 = 1
k2 = 1
For i = 2 To i_n1
  Key2 = Tabl1(1, i) & Tabl1(2, i)
  If Not Obj2.exists(Key2) Then
     k1 = k1 + 1
     ReDim Preserve NeSovp(2, UBound(NeSovp, 2) + 1)
     NeSovp(1, k1) = Tabl1(1, i)
     NeSovp(2, k1) = Tabl1(2, i)
  Else
     If Not Obj3.exists(Key2) Then
        Obj3.Add Key2, Tabl1(2, i)
        k2 = k2 + 1
        ReDim Preserve Sovp(2, UBound(Sovp, 2) + 1)
        Sovp(1, k2) = Tabl1(1, i)
        Sovp(2, k2) = Tabl1(2, i)
     End If
  End If
Next i
For i = 2 To i_n2
  Key1 = Tabl2(1, i) & Tabl2(2, i)
  If Not Obj1.exists(Key1) Then
     k1 = k1 + 1
     ReDim Preserve NeSovp(2, UBound(NeSovp, 2) + 1)
     NeSovp(1, k1) = Tabl2(1, i)
     NeSovp(2, k1) = Tabl2(2, i)
  Else
     If Not Obj3.exists(Key1) Then
        Obj3.Add Key1, Tabl2(2, i)
        k2 = k2 + 1
        ReDim Preserve Sovp(2, UBound(Sovp, 2) + 1)
        Sovp(1, k2) = Tabl2(1, i)
        Sovp(2, k2) = Tabl2(2, i)
     End If
  End If
Next i
On Error Resume Next
Set WS = Sheets("Совпали")
If WS Is Nothing Then
   Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Совпали"
Else
   WS.Cells.Clear
End If
Set WS = Nothing
On Error Resume Next
Set WS = Sheets("Несовпали")
If WS Is Nothing Then
   Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Несовпали"
Else
   WS.Cells.Clear
End If
For i = 1 To UBound(Sovp, 2)
  Worksheets("Совпали").Cells(i, 1) = Sovp(1, i)
  Worksheets("Совпали").Cells(i, 2) = Sovp(2, i)
Next i
For i = 1 To UBound(NeSovp, 2)
  Worksheets("Несовпали").Cells(i, 1) = NeSovp(1, i)
  Worksheets("Несовпали").Cells(i, 2) = NeSovp(2, i)
Next i
Worksheets(1).Range("A2:B2").Copy
With Worksheets("Совпали").UsedRange
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Rows.AutoFit
.Range(Cells(1, 1)).CurrentRegion.Sort Key1:=.Cells(1), Order1:=xlAscending, Orientation:=xlLeftToRight
End With
With Worksheets("Несовпали").UsedRange
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Rows.AutoFit
.Range(Cells(1, 1)).CurrentRegion.Sort Key1:=.Cells(1), Order1:=xlAscending, Orientation:=xlLeftToRight
End With
End Sub

[/vba]

К сообщению приложен файл: _-__.xls (64.5 Kb)

Много чего не знаю!!!!

Ответить

СообщениеAnnaKudrina, Муторно как-то, но вроде работает...

[vba]

Код

Sub Sravn()
Dim i As Long, i_n1 As Long, i_n2 As Long
Dim Tabl1() As String, Tabl2() As String, Sovp() As String, NeSovp() As String, k1 As Long, k2 As Long
Dim Obj1 As Object, Obj2 As Object, Key1 As String, Key2 As String, Obj3 As Object
Dim WS As Worksheet
Set Obj1 = CreateObject("Scripting.dictionary")
Set Obj2 = CreateObject("Scripting.dictionary")
Set Obj3 = CreateObject("Scripting.dictionary")
i_n1 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
ReDim Tabl1(2, i_n1)
For i = 1 To i_n1
Tabl1(1, i) = Trim(Worksheets(1).Cells(i, 1))
Tabl1(2, i) = Trim(Worksheets(1).Cells(i, 2))
Next i
i_n2 = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row
ReDim Tabl2(2, i_n2)
For i = 1 To i_n2
Tabl2(1, i) = Trim(Worksheets(2).Cells(i, 2))
Tabl2(2, i) = Trim(Worksheets(2).Cells(i, 3))
Next i
For i = 2 To i_n1
  Key1 = Tabl1(1, i) & Tabl1(2, i)
  If Not Obj1.exists(Key1) Then
    Obj1.Add Key1, Tabl1(2, i)
  End If
Next i
For i = 2 To i_n2
  Key2 = Tabl2(1, i) & Tabl2(2, i)
  If Not Obj2.exists(Key1) Then
    Obj2.Add Key2, Tabl2(2, i)
  End If
Next i
ReDim Sovp(2, 1)
ReDim NeSovp(2, 1)
Sovp(1, 1) = Tabl1(1, 1)
Sovp(2, 1) = Tabl1(2, 1)
NeSovp(1, 1) = Tabl1(1, 1)
NeSovp(2, 1) = Tabl1(2, 1)
k1 = 1
k2 = 1
For i = 2 To i_n1
  Key2 = Tabl1(1, i) & Tabl1(2, i)
  If Not Obj2.exists(Key2) Then
     k1 = k1 + 1
     ReDim Preserve NeSovp(2, UBound(NeSovp, 2) + 1)
     NeSovp(1, k1) = Tabl1(1, i)
     NeSovp(2, k1) = Tabl1(2, i)
  Else
     If Not Obj3.exists(Key2) Then
        Obj3.Add Key2, Tabl1(2, i)
        k2 = k2 + 1
        ReDim Preserve Sovp(2, UBound(Sovp, 2) + 1)
        Sovp(1, k2) = Tabl1(1, i)
        Sovp(2, k2) = Tabl1(2, i)
     End If
  End If
Next i
For i = 2 To i_n2
  Key1 = Tabl2(1, i) & Tabl2(2, i)
  If Not Obj1.exists(Key1) Then
     k1 = k1 + 1
     ReDim Preserve NeSovp(2, UBound(NeSovp, 2) + 1)
     NeSovp(1, k1) = Tabl2(1, i)
     NeSovp(2, k1) = Tabl2(2, i)
  Else
     If Not Obj3.exists(Key1) Then
        Obj3.Add Key1, Tabl2(2, i)
        k2 = k2 + 1
        ReDim Preserve Sovp(2, UBound(Sovp, 2) + 1)
        Sovp(1, k2) = Tabl2(1, i)
        Sovp(2, k2) = Tabl2(2, i)
     End If
  End If
Next i
On Error Resume Next
Set WS = Sheets("Совпали")
If WS Is Nothing Then
   Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Совпали"
Else
   WS.Cells.Clear
End If
Set WS = Nothing
On Error Resume Next
Set WS = Sheets("Несовпали")
If WS Is Nothing Then
   Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Несовпали"
Else
   WS.Cells.Clear
End If
For i = 1 To UBound(Sovp, 2)
  Worksheets("Совпали").Cells(i, 1) = Sovp(1, i)
  Worksheets("Совпали").Cells(i, 2) = Sovp(2, i)
Next i
For i = 1 To UBound(NeSovp, 2)
  Worksheets("Несовпали").Cells(i, 1) = NeSovp(1, i)
  Worksheets("Несовпали").Cells(i, 2) = NeSovp(2, i)
Next i
Worksheets(1).Range("A2:B2").Copy
With Worksheets("Совпали").UsedRange
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Rows.AutoFit
.Range(Cells(1, 1)).CurrentRegion.Sort Key1:=.Cells(1), Order1:=xlAscending, Orientation:=xlLeftToRight
End With
With Worksheets("Несовпали").UsedRange
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Rows.AutoFit
.Range(Cells(1, 1)).CurrentRegion.Sort Key1:=.Cells(1), Order1:=xlAscending, Orientation:=xlLeftToRight
End With
End Sub

[/vba]

Автор - Roman777
Дата добавления - 09.12.2015 в 13:36

Дата: Среда, 09.12.2015, 14:31 | Сообщение № 8

Группа: Пользователи

Ранг: Прохожий

Сообщений: 8

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Roman777, спасибо Вам большое. Вроде работает. А подскажите как добавить в итоговые таблицы еще один столбец с данными и таблиц Д и П

Ответить

Дата: Среда, 09.12.2015, 15:27 | Сообщение № 9

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация: 127 ±

Замечаний: 0% ±

Excel 2007, Excel 2013

AnnaKudrina, Что именно Вы хотите добавить, покажите пример. Так просто, думаю, не добавить. Скорее всего придётся массивы увеличивать по одному измерению на 1 или более элементов.

Много чего не знаю!!!!

Ответить

Дата: Среда, 09.12.2015, 17:04 | Сообщение № 10

Группа: Друзья

Ранг: Участник клуба

Сообщений: 2748

Репутация: 1137 ±

Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1

В подобных задачах хорошо рулят SQL и ADO.

К сообщению приложен файл: Kudrina.xls (52.5 Kb)

МОИ: Ник, Tip box: 41001663842605

Ответить

Дата: Четверг, 10.12.2015, 09:46 | Сообщение № 11

Группа: Пользователи

Ранг: Прохожий

Сообщений: 8

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Gustav, А если упростить задачу. Будет одна таблица (Имя клиента, СНИЛС ,Адрес доставки), и сравнивать необходимо по Имени клиента и СНИЛС. Как результат после сравнения создать две новые таблицы. В первую таблицу перенести различия (имя клиента, СНИЛС, Адрес доставки), а во вторую совпадения (имя клиента, СНИЛС, Адрес доставки). В прикрепленном файле образец таблиц П, в реале записей более 4000.
Заранее благодарна за помощь!

К сообщению приложен файл: 5195012.xls (31.0 Kb)

Ответить

Дата: Четверг, 10.12.2015, 16:58 | Сообщение № 12

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация: 127 ±

Замечаний: 0% ±

Excel 2007, Excel 2013

AnnaKudrina, Не очень ясно, что будет совпадением, а что отличием в этом случае. Не могли бы Вы привести примеры различия и совпадения?

Много чего не знаю!!!!

Ответить

Дата: Четверг, 10.12.2015, 18:52 | Сообщение № 13

Группа: Друзья

Ранг: Участник клуба

Сообщений: 2748

Репутация: 1137 ±

Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1

Ну, я тоже немного поразглагольствую по делу. Итак...

Если для заданного Имени клиента и СНИЛС найдётся только одна запись. Она куда должна пойти? В "Совпадения" или "Различия"?

С двумя записями, наверное, интуитивно понятно - или в "Совпадения", или в "Различия" - в зависимости от содержания поля Адрес доставки (это я чисто логически фантазирую, может, оно и не так вовсе).

Если для заданного Имени клиента и СНИЛС найдутся, например, три записи, две из которых совпадут, а третья нет. Куда направлять две и куда одну?

И мне представляется, что при одной таблице тут и макросы-то не особо нужны. Можно отсортировать ее по всем трем полям по возрастанию и потом формулками проверить совпадения полей в соседних записях. Дело за малым - ясно представлять, что именно проверять

МОИ: Ник, Tip box: 41001663842605

Ответить

Дата: Пятница, 11.12.2015, 07:41 | Сообщение № 14

Группа: Пользователи

Ранг: Прохожий

Сообщений: 8

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Gustav, объясню на примере вложенного файла. Есть клиенты Абаканова Сатвальда Желгедовна 095-922-391 34, Абраменко Валентина Даниловна 101-000-928 41, Абрамова Зоя Иосифовна 078-406-246 00, Абрашкова Тамара Николаевна 101-560-106 75 они в таблице повторяются (то есть и по имени, и по снилс), вот их надо перенести в таблицу совпадений (со столбцами имя клиента, снилс и адрес доставки), а остальных в таблицу различий (со столбцами имя клиента, снилс и адрес доставки). То есть совпадения должны быть имя и по имени клиента и по снилс. Мне кажется, что лучше написать макрос, потому таких таблиц много, и в некоторых записей больше 10000.

Ответить

Дата: Пятница, 11.12.2015, 07:42 | Сообщение № 15

Группа: Пользователи

Ранг: Прохожий

Сообщений: 8

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Roman777, объясню на примере вложенного файла. Есть клиенты Абаканова Сатвальда Желгедовна 095-922-391 34, Абраменко Валентина Даниловна 101-000-928 41, Абрамова Зоя Иосифовна 078-406-246 00, Абрашкова Тамара Николаевна 101-560-106 75 они в таблице повторяются (то есть и по имени, и по снилс), вот их надо перенести в таблицу совпадений (со столбцами имя клиента, снилс и адрес доставки), а остальных в таблицу различий (со столбцами имя клиента, снилс и адрес доставки)

Ответить

Дата: Пятница, 11.12.2015, 12:40 | Сообщение № 16

Группа: Друзья

Ранг: Участник клуба

Сообщений: 2748

Репутация: 1137 ±

Замечаний: 0% ±

начинал с Excel 4.0, видел 2.1

Цитата AnnaKudrina, 11.12.2015 в 07:42, в сообщении № 15

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

Что ж, SQL рулит дальше! Запрос получился не очень простой и, что греха таить, конструировал я его не без помощи мастера запросов MS Access. Но менее эффектным он от этого не стал!

Цитата AnnaKudrina, 11.12.2015 в 07:42, в сообщении № 15

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

Что ж, SQL рулит дальше! Запрос получился не очень простой и, что греха таить, конструировал я его не без помощи мастера запросов MS Access. Но менее эффектным он от этого не стал!

К сообщению приложен файл: Kudrina2.xls (38.5 Kb)

МОИ: Ник, Tip box: 41001663842605

Ответить

Сообщение

Цитата AnnaKudrina, 11.12.2015 в 07:42, в сообщении № 15

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

Что ж, SQL рулит дальше! Запрос получился не очень простой и, что греха таить, конструировал я его не без помощи мастера запросов MS Access. Но менее эффектным он от этого не стал!

Автор - Gustav
Дата добавления - 11.12.2015 в 12:40

Дата: Пятница, 11.12.2015, 12:50 | Сообщение № 17

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация: 127 ±

Замечаний: 0% ±

Excel 2007, Excel 2013

У меня всё так же по-старому через словари и массивы:

[vba]

Код

Sub Sravn2()
Dim i As Long, i_n1 As Long
Dim Tabl1() As String, Tabl2() As String, Sovp() As String, NeSovp() As String, k1 As Long, kol As Long
Dim Obj1 As Object, Key1 As String
Dim WS As Worksheet
Set Obj1 = CreateObject("Scripting.dictionary")
i_n1 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
ReDim Tabl1(3, i_n1)
For i = 1 To i_n1
Tabl1(1, i) = Trim(Worksheets(1).Cells(i, 1))
Tabl1(2, i) = Trim(Worksheets(1).Cells(i, 2))
Tabl1(3, i) = Trim(Worksheets(1).Cells(i, 3))
Next i
ReDim Sovp(3, 1)
ReDim NeSovp(3, 1)
Sovp(1, 1) = Tabl1(1, 1)
Sovp(2, 1) = Tabl1(2, 1)
Sovp(3, 1) = Tabl1(3, 1)
NeSovp(1, 1) = Tabl1(1, 1)
NeSovp(2, 1) = Tabl1(2, 1)
NeSovp(3, 1) = Tabl1(3, 1)
ReDim Tabl2(5, 1)
For i = 2 To i_n1
  Key1 = Tabl1(1, i) & Tabl1(2, i)
  If Not Obj1.exists(Key1) Then
     k1 = k1 + 1
     Obj1.Add Key1, CStr(k1)
     ReDim Preserve Tabl2(5, k1)
     Tabl2(1, k1) = Tabl1(1, i)
     Tabl2(2, k1) = Tabl1(2, i)
     Tabl2(3, k1) = Tabl1(3, i)
     Tabl2(4, k1) = 0
  End If
Next i
k1 = 1
k2 = 1
For i = 2 To i_n1
  Key1 = Tabl1(1, i) & Tabl1(2, i)
  If Obj1.exists(Key1) Then
     Tabl2(4, Obj1(Key1)) = Tabl2(4, Obj1(Key1)) + 1
  End If
Next i
For i = 1 To UBound(Tabl2, 2)
  If Tabl2(4, i) > 1 Then
     k2 = k2 + 1
     ReDim Preserve Sovp(3, k2)
     Sovp(1, k2) = Tabl2(1, i)
     Sovp(2, k2) = Tabl2(2, i)
     Sovp(3, k2) = Tabl2(3, i)
  Else
     k1 = k1 + 1
     ReDim Preserve NeSovp(3, k1)
     NeSovp(1, k1) = Tabl2(1, i)
     NeSovp(2, k1) = Tabl2(2, i)
     NeSovp(3, k1) = Tabl2(3, i)
  End If
Next i
On Error Resume Next
Set WS = Sheets("Совпали")
If WS Is Nothing Then
   Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Совпали"
   Sheets(1).Rows(1).Copy Sheets("Совпали").Cells(1, 1)
Else
   WS.Cells.Clear
   Sheets(1).Rows(1).Copy Sheets("Совпали").Cells(1, 1)
End If
Set WS = Nothing
On Error Resume Next
Set WS = Sheets("Несовпали")
If WS Is Nothing Then
   Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Несовпали"
   Sheets(1).Rows(1).Copy Sheets("Несовпали").Cells(1, 1)
Else
   WS.Cells.Clear
   Sheets(1).Rows(1).Copy Sheets("Несовпали").Cells(1, 1)
End If
For i = 1 To UBound(Sovp, 2)
  Worksheets("Совпали").Cells(i, 1) = Sovp(1, i)
  Worksheets("Совпали").Cells(i, 2) = Sovp(2, i)
  Worksheets("Совпали").Cells(i, 3) = Sovp(3, i)
Next i
For i = 1 To UBound(NeSovp, 2)
  Worksheets("Несовпали").Cells(i, 1) = NeSovp(1, i)
  Worksheets("Несовпали").Cells(i, 2) = NeSovp(2, i)
  Worksheets("Несовпали").Cells(i, 3) = NeSovp(3, i)
Next i
Worksheets(1).Range("A2:C2").Copy
With Worksheets("Совпали").UsedRange
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Rows.AutoFit
.Range(Cells(1, 1)).CurrentRegion.Sort Key1:=.Cells(1), Order1:=xlAscending, Orientation:=xlLeftToRight
End With
With Worksheets("Несовпали").UsedRange
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Rows.AutoFit
.Range(Cells(1, 1)).CurrentRegion.Sort Key1:=.Cells(1), Order1:=xlAscending, Orientation:=xlLeftToRight
End With
End Sub

[/vba]

Но то как это выглядит у Gustav мне нравится больше, хотя, пока что моё более понятно для меня).

У меня всё так же по-старому через словари и массивы:

[vba]

Код

Sub Sravn2()
Dim i As Long, i_n1 As Long
Dim Tabl1() As String, Tabl2() As String, Sovp() As String, NeSovp() As String, k1 As Long, kol As Long
Dim Obj1 As Object, Key1 As String
Dim WS As Worksheet
Set Obj1 = CreateObject("Scripting.dictionary")
i_n1 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
ReDim Tabl1(3, i_n1)
For i = 1 To i_n1
Tabl1(1, i) = Trim(Worksheets(1).Cells(i, 1))
Tabl1(2, i) = Trim(Worksheets(1).Cells(i, 2))
Tabl1(3, i) = Trim(Worksheets(1).Cells(i, 3))
Next i
ReDim Sovp(3, 1)
ReDim NeSovp(3, 1)
Sovp(1, 1) = Tabl1(1, 1)
Sovp(2, 1) = Tabl1(2, 1)
Sovp(3, 1) = Tabl1(3, 1)
NeSovp(1, 1) = Tabl1(1, 1)
NeSovp(2, 1) = Tabl1(2, 1)
NeSovp(3, 1) = Tabl1(3, 1)
ReDim Tabl2(5, 1)
For i = 2 To i_n1
  Key1 = Tabl1(1, i) & Tabl1(2, i)
  If Not Obj1.exists(Key1) Then
     k1 = k1 + 1
     Obj1.Add Key1, CStr(k1)
     ReDim Preserve Tabl2(5, k1)
     Tabl2(1, k1) = Tabl1(1, i)
     Tabl2(2, k1) = Tabl1(2, i)
     Tabl2(3, k1) = Tabl1(3, i)
     Tabl2(4, k1) = 0
  End If
Next i
k1 = 1
k2 = 1
For i = 2 To i_n1
  Key1 = Tabl1(1, i) & Tabl1(2, i)
  If Obj1.exists(Key1) Then
     Tabl2(4, Obj1(Key1)) = Tabl2(4, Obj1(Key1)) + 1
  End If
Next i
For i = 1 To UBound(Tabl2, 2)
  If Tabl2(4, i) > 1 Then
     k2 = k2 + 1
     ReDim Preserve Sovp(3, k2)
     Sovp(1, k2) = Tabl2(1, i)
     Sovp(2, k2) = Tabl2(2, i)
     Sovp(3, k2) = Tabl2(3, i)
  Else
     k1 = k1 + 1
     ReDim Preserve NeSovp(3, k1)
     NeSovp(1, k1) = Tabl2(1, i)
     NeSovp(2, k1) = Tabl2(2, i)
     NeSovp(3, k1) = Tabl2(3, i)
  End If
Next i
On Error Resume Next
Set WS = Sheets("Совпали")
If WS Is Nothing Then
   Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Совпали"
   Sheets(1).Rows(1).Copy Sheets("Совпали").Cells(1, 1)
Else
   WS.Cells.Clear
   Sheets(1).Rows(1).Copy Sheets("Совпали").Cells(1, 1)
End If
Set WS = Nothing
On Error Resume Next
Set WS = Sheets("Несовпали")
If WS Is Nothing Then
   Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Несовпали"
   Sheets(1).Rows(1).Copy Sheets("Несовпали").Cells(1, 1)
Else
   WS.Cells.Clear
   Sheets(1).Rows(1).Copy Sheets("Несовпали").Cells(1, 1)
End If
For i = 1 To UBound(Sovp, 2)
  Worksheets("Совпали").Cells(i, 1) = Sovp(1, i)
  Worksheets("Совпали").Cells(i, 2) = Sovp(2, i)
  Worksheets("Совпали").Cells(i, 3) = Sovp(3, i)
Next i
For i = 1 To UBound(NeSovp, 2)
  Worksheets("Несовпали").Cells(i, 1) = NeSovp(1, i)
  Worksheets("Несовпали").Cells(i, 2) = NeSovp(2, i)
  Worksheets("Несовпали").Cells(i, 3) = NeSovp(3, i)
Next i
Worksheets(1).Range("A2:C2").Copy
With Worksheets("Совпали").UsedRange
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Rows.AutoFit
.Range(Cells(1, 1)).CurrentRegion.Sort Key1:=.Cells(1), Order1:=xlAscending, Orientation:=xlLeftToRight
End With
With Worksheets("Несовпали").UsedRange
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Rows.AutoFit
.Range(Cells(1, 1)).CurrentRegion.Sort Key1:=.Cells(1), Order1:=xlAscending, Orientation:=xlLeftToRight
End With
End Sub

[/vba]

Но то как это выглядит у Gustav мне нравится больше, хотя, пока что моё более понятно для меня).Roman777

К сообщению приложен файл: 2-.xls (41.5 Kb)

Много чего не знаю!!!!

Ответить

СообщениеУ меня всё так же по-старому через словари и массивы:

[vba]

Код

Sub Sravn2()
Dim i As Long, i_n1 As Long
Dim Tabl1() As String, Tabl2() As String, Sovp() As String, NeSovp() As String, k1 As Long, kol As Long
Dim Obj1 As Object, Key1 As String
Dim WS As Worksheet
Set Obj1 = CreateObject("Scripting.dictionary")
i_n1 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
ReDim Tabl1(3, i_n1)
For i = 1 To i_n1
Tabl1(1, i) = Trim(Worksheets(1).Cells(i, 1))
Tabl1(2, i) = Trim(Worksheets(1).Cells(i, 2))
Tabl1(3, i) = Trim(Worksheets(1).Cells(i, 3))
Next i
ReDim Sovp(3, 1)
ReDim NeSovp(3, 1)
Sovp(1, 1) = Tabl1(1, 1)
Sovp(2, 1) = Tabl1(2, 1)
Sovp(3, 1) = Tabl1(3, 1)
NeSovp(1, 1) = Tabl1(1, 1)
NeSovp(2, 1) = Tabl1(2, 1)
NeSovp(3, 1) = Tabl1(3, 1)
ReDim Tabl2(5, 1)
For i = 2 To i_n1
  Key1 = Tabl1(1, i) & Tabl1(2, i)
  If Not Obj1.exists(Key1) Then
     k1 = k1 + 1
     Obj1.Add Key1, CStr(k1)
     ReDim Preserve Tabl2(5, k1)
     Tabl2(1, k1) = Tabl1(1, i)
     Tabl2(2, k1) = Tabl1(2, i)
     Tabl2(3, k1) = Tabl1(3, i)
     Tabl2(4, k1) = 0
  End If
Next i
k1 = 1
k2 = 1
For i = 2 To i_n1
  Key1 = Tabl1(1, i) & Tabl1(2, i)
  If Obj1.exists(Key1) Then
     Tabl2(4, Obj1(Key1)) = Tabl2(4, Obj1(Key1)) + 1
  End If
Next i
For i = 1 To UBound(Tabl2, 2)
  If Tabl2(4, i) > 1 Then
     k2 = k2 + 1
     ReDim Preserve Sovp(3, k2)
     Sovp(1, k2) = Tabl2(1, i)
     Sovp(2, k2) = Tabl2(2, i)
     Sovp(3, k2) = Tabl2(3, i)
  Else
     k1 = k1 + 1
     ReDim Preserve NeSovp(3, k1)
     NeSovp(1, k1) = Tabl2(1, i)
     NeSovp(2, k1) = Tabl2(2, i)
     NeSovp(3, k1) = Tabl2(3, i)
  End If
Next i
On Error Resume Next
Set WS = Sheets("Совпали")
If WS Is Nothing Then
   Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Совпали"
   Sheets(1).Rows(1).Copy Sheets("Совпали").Cells(1, 1)
Else
   WS.Cells.Clear
   Sheets(1).Rows(1).Copy Sheets("Совпали").Cells(1, 1)
End If
Set WS = Nothing
On Error Resume Next
Set WS = Sheets("Несовпали")
If WS Is Nothing Then
   Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Несовпали"
   Sheets(1).Rows(1).Copy Sheets("Несовпали").Cells(1, 1)
Else
   WS.Cells.Clear
   Sheets(1).Rows(1).Copy Sheets("Несовпали").Cells(1, 1)
End If
For i = 1 To UBound(Sovp, 2)
  Worksheets("Совпали").Cells(i, 1) = Sovp(1, i)
  Worksheets("Совпали").Cells(i, 2) = Sovp(2, i)
  Worksheets("Совпали").Cells(i, 3) = Sovp(3, i)
Next i
For i = 1 To UBound(NeSovp, 2)
  Worksheets("Несовпали").Cells(i, 1) = NeSovp(1, i)
  Worksheets("Несовпали").Cells(i, 2) = NeSovp(2, i)
  Worksheets("Несовпали").Cells(i, 3) = NeSovp(3, i)
Next i
Worksheets(1).Range("A2:C2").Copy
With Worksheets("Совпали").UsedRange
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Rows.AutoFit
.Range(Cells(1, 1)).CurrentRegion.Sort Key1:=.Cells(1), Order1:=xlAscending, Orientation:=xlLeftToRight
End With
With Worksheets("Несовпали").UsedRange
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Rows.AutoFit
.Range(Cells(1, 1)).CurrentRegion.Sort Key1:=.Cells(1), Order1:=xlAscending, Orientation:=xlLeftToRight
End With
End Sub

[/vba]

Но то как это выглядит у Gustav мне нравится больше, хотя, пока что моё более понятно для меня).

Автор - Roman777
Дата добавления - 11.12.2015 в 12:50

Дата: Понедельник, 14.12.2015, 07:22 | Сообщение № 18

Группа: Пользователи

Ранг: Прохожий

Сообщений: 8

Репутация: 0 ±

Замечаний: 0% ±

Excel 2010

Gustav, Roman777, спасибо большое все работает. А есть ли возможность переноса заливки вместе с данными в таблицы Различия и Совпадения. То есть некоторые строки будут иметь заливку фона, и чтобы эта заливка также переносилась вместе с данными в таблицы различий и совпадений?

Сообщение отредактировал AnnaKudrina - Понедельник, 14.12.2015, 08:09

Ответить

Дата: Понедельник, 14.12.2015, 09:59 | Сообщение № 19

Группа: Проверенные

Ранг: Ветеран

Сообщений: 980

Репутация: 127 ±

Замечаний: 0% ±

Excel 2007, Excel 2013

AnnaKudrina, с копированием заливки, думаю, в реальном файле, макрос уже будет отрабатывать по времени не быстро.

[vba]

Код

Sub Sravn3()
Dim i As Long, i_n1 As Long
Dim Tabl1() As String, Tabl2() As String, Sovp() As String, NeSovp() As String, k1 As Long, kol As Long
Dim Obj1 As Object, Key1 As String
Dim WS As Worksheet
Set Obj1 = CreateObject("Scripting.dictionary")
i_n1 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
ReDim Tabl1(2, 3, i_n1)
For i = 1 To i_n1
Tabl1(1, 1, i) = Trim(Worksheets(1).Cells(i, 1))
Tabl1(1, 2, i) = Trim(Worksheets(1).Cells(i, 2))
Tabl1(1, 3, i) = Trim(Worksheets(1).Cells(i, 3))
Tabl1(2, 1, i) = Worksheets(1).Cells(i, 1).Interior.Color
Tabl1(2, 2, i) = Worksheets(1).Cells(i, 2).Interior.Color
Tabl1(2, 3, i) = Worksheets(1).Cells(i, 3).Interior.Color
Next i
ReDim Sovp(2, 3, 1)
ReDim NeSovp(2, 3, 1)
Sovp(1, 1, 1) = Tabl1(1, 1, 1)
Sovp(1, 2, 1) = Tabl1(1, 2, 1)
Sovp(1, 3, 1) = Tabl1(1, 3, 1)
NeSovp(1, 1, 1) = Tabl1(1, 1, 1)
NeSovp(1, 2, 1) = Tabl1(1, 2, 1)
NeSovp(1, 3, 1) = Tabl1(1, 3, 1)
Sovp(2, 1, 1) = Tabl1(2, 1, 1)
Sovp(2, 2, 1) = Tabl1(2, 2, 1)
Sovp(2, 3, 1) = Tabl1(2, 3, 1)
NeSovp(2, 1, 1) = Tabl1(2, 1, 1)
NeSovp(2, 2, 1) = Tabl1(2, 2, 1)
NeSovp(2, 3, 1) = Tabl1(2, 3, 1)
ReDim Tabl2(2, 5, 1)
For i = 2 To i_n1
  Key1 = Tabl1(1, 1, i) & Tabl1(1, 2, i)
  If Not Obj1.exists(Key1) Then
     k1 = k1 + 1
     Obj1.Add Key1, CStr(k1)
     ReDim Preserve Tabl2(2, 5, k1)
     Tabl2(1, 1, k1) = Tabl1(1, 1, i)
     Tabl2(1, 2, k1) = Tabl1(1, 2, i)
     Tabl2(1, 3, k1) = Tabl1(1, 3, i)
     Tabl2(1, 4, k1) = 0
     Tabl2(2, 1, k1) = Tabl1(2, 1, i)
     Tabl2(2, 2, k1) = Tabl1(2, 2, i)
     Tabl2(2, 3, k1) = Tabl1(2, 3, i)
  End If
Next i
k1 = 1
k2 = 1
For i = 2 To i_n1
  Key1 = Tabl1(1, 1, i) & Tabl1(1, 2, i)
  If Obj1.exists(Key1) Then
     Tabl2(1, 4, Obj1(Key1)) = Tabl2(1, 4, Obj1(Key1)) + 1
  End If
Next i
For i = 1 To UBound(Tabl2, 3)
  If Tabl2(1, 4, i) > 1 Then
     k2 = k2 + 1
     ReDim Preserve Sovp(2, 3, k2)
     Sovp(1, 1, k2) = Tabl2(1, 1, i)
     Sovp(1, 2, k2) = Tabl2(1, 2, i)
     Sovp(1, 3, k2) = Tabl2(1, 3, i)
     Sovp(2, 1, k2) = Tabl2(2, 1, i)
     Sovp(2, 2, k2) = Tabl2(2, 2, i)
     Sovp(2, 3, k2) = Tabl2(2, 3, i)
  Else
     k1 = k1 + 1
     ReDim Preserve NeSovp(2, 3, k1)
     NeSovp(1, 1, k1) = Tabl2(1, 1, i)
     NeSovp(1, 2, k1) = Tabl2(1, 2, i)
     NeSovp(1, 3, k1) = Tabl2(1, 3, i)
     NeSovp(2, 1, k1) = Tabl2(2, 1, i)
     NeSovp(2, 2, k1) = Tabl2(2, 2, i)
     NeSovp(2, 3, k1) = Tabl2(2, 3, i)
  End If
Next i
On Error Resume Next
Set WS = Sheets("Совпали")
If WS Is Nothing Then
   Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Совпали"
   Sheets(1).Rows(1).Copy Sheets("Совпали").Cells(1, 1)
Else
   WS.Cells.Clear
   Sheets(1).Rows(1).Copy Sheets("Совпали").Cells(1, 1)
End If
Set WS = Nothing
On Error Resume Next
Set WS = Sheets("Несовпали")
If WS Is Nothing Then
   Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Несовпали"
   Sheets(1).Rows(1).Copy Sheets("Несовпали").Cells(1, 1)
Else
   WS.Cells.Clear
   Sheets(1).Rows(1).Copy Sheets("Несовпали").Cells(1, 1)
End If
Worksheets(1).Range("A2:C2").Copy
With Worksheets("Совпали").Cells(1, 1).Resize(UBound(Sovp, 3), 3)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Rows.AutoFit
.Range(Cells(1, 1)).CurrentRegion.Sort Key1:=.Cells(1), Order1:=xlAscending, Orientation:=xlLeftToRight
End With
With Worksheets("Несовпали").Cells(1, 1).Resize(UBound(NeSovp, 3), 3)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Rows.AutoFit
.Range(Cells(1, 1)).CurrentRegion.Sort Key1:=.Cells(1), Order1:=xlAscending, Orientation:=xlLeftToRight
End With
For i = 1 To UBound(Sovp, 3)
  Worksheets("Совпали").Cells(i, 1) = Sovp(1, 1, i)
  Worksheets("Совпали").Cells(i, 2) = Sovp(1, 2, i)
  Worksheets("Совпали").Cells(i, 3) = Sovp(1, 3, i)
  Worksheets("Совпали").Cells(i, 1).Interior.Color = Sovp(2, 1, i)
  Worksheets("Совпали").Cells(i, 2).Interior.Color = Sovp(2, 2, i)
  Worksheets("Совпали").Cells(i, 3).Interior.Color = Sovp(2, 3, i)
Next i
For i = 1 To UBound(NeSovp, 3)
  Worksheets("Несовпали").Cells(i, 1) = NeSovp(1, 1, i)
  Worksheets("Несовпали").Cells(i, 2) = NeSovp(1, 2, i)
  Worksheets("Несовпали").Cells(i, 3) = NeSovp(1, 3, i)
  Worksheets("Несовпали").Cells(i, 1).Interior.Color = NeSovp(2, 1, i)
  Worksheets("Несовпали").Cells(i, 2).Interior.Color = NeSovp(2, 2, i)
  Worksheets("Несовпали").Cells(i, 3).Interior.Color = NeSovp(2, 3, i)
Next i
End Sub

[/vba]

AnnaKudrina, с копированием заливки, думаю, в реальном файле, макрос уже будет отрабатывать по времени не быстро.

[vba]

Код

Sub Sravn3()
Dim i As Long, i_n1 As Long
Dim Tabl1() As String, Tabl2() As String, Sovp() As String, NeSovp() As String, k1 As Long, kol As Long
Dim Obj1 As Object, Key1 As String
Dim WS As Worksheet
Set Obj1 = CreateObject("Scripting.dictionary")
i_n1 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
ReDim Tabl1(2, 3, i_n1)
For i = 1 To i_n1
Tabl1(1, 1, i) = Trim(Worksheets(1).Cells(i, 1))
Tabl1(1, 2, i) = Trim(Worksheets(1).Cells(i, 2))
Tabl1(1, 3, i) = Trim(Worksheets(1).Cells(i, 3))
Tabl1(2, 1, i) = Worksheets(1).Cells(i, 1).Interior.Color
Tabl1(2, 2, i) = Worksheets(1).Cells(i, 2).Interior.Color
Tabl1(2, 3, i) = Worksheets(1).Cells(i, 3).Interior.Color
Next i
ReDim Sovp(2, 3, 1)
ReDim NeSovp(2, 3, 1)
Sovp(1, 1, 1) = Tabl1(1, 1, 1)
Sovp(1, 2, 1) = Tabl1(1, 2, 1)
Sovp(1, 3, 1) = Tabl1(1, 3, 1)
NeSovp(1, 1, 1) = Tabl1(1, 1, 1)
NeSovp(1, 2, 1) = Tabl1(1, 2, 1)
NeSovp(1, 3, 1) = Tabl1(1, 3, 1)
Sovp(2, 1, 1) = Tabl1(2, 1, 1)
Sovp(2, 2, 1) = Tabl1(2, 2, 1)
Sovp(2, 3, 1) = Tabl1(2, 3, 1)
NeSovp(2, 1, 1) = Tabl1(2, 1, 1)
NeSovp(2, 2, 1) = Tabl1(2, 2, 1)
NeSovp(2, 3, 1) = Tabl1(2, 3, 1)
ReDim Tabl2(2, 5, 1)
For i = 2 To i_n1
  Key1 = Tabl1(1, 1, i) & Tabl1(1, 2, i)
  If Not Obj1.exists(Key1) Then
     k1 = k1 + 1
     Obj1.Add Key1, CStr(k1)
     ReDim Preserve Tabl2(2, 5, k1)
     Tabl2(1, 1, k1) = Tabl1(1, 1, i)
     Tabl2(1, 2, k1) = Tabl1(1, 2, i)
     Tabl2(1, 3, k1) = Tabl1(1, 3, i)
     Tabl2(1, 4, k1) = 0
     Tabl2(2, 1, k1) = Tabl1(2, 1, i)
     Tabl2(2, 2, k1) = Tabl1(2, 2, i)
     Tabl2(2, 3, k1) = Tabl1(2, 3, i)
  End If
Next i
k1 = 1
k2 = 1
For i = 2 To i_n1
  Key1 = Tabl1(1, 1, i) & Tabl1(1, 2, i)
  If Obj1.exists(Key1) Then
     Tabl2(1, 4, Obj1(Key1)) = Tabl2(1, 4, Obj1(Key1)) + 1
  End If
Next i
For i = 1 To UBound(Tabl2, 3)
  If Tabl2(1, 4, i) > 1 Then
     k2 = k2 + 1
     ReDim Preserve Sovp(2, 3, k2)
     Sovp(1, 1, k2) = Tabl2(1, 1, i)
     Sovp(1, 2, k2) = Tabl2(1, 2, i)
     Sovp(1, 3, k2) = Tabl2(1, 3, i)
     Sovp(2, 1, k2) = Tabl2(2, 1, i)
     Sovp(2, 2, k2) = Tabl2(2, 2, i)
     Sovp(2, 3, k2) = Tabl2(2, 3, i)
  Else
     k1 = k1 + 1
     ReDim Preserve NeSovp(2, 3, k1)
     NeSovp(1, 1, k1) = Tabl2(1, 1, i)
     NeSovp(1, 2, k1) = Tabl2(1, 2, i)
     NeSovp(1, 3, k1) = Tabl2(1, 3, i)
     NeSovp(2, 1, k1) = Tabl2(2, 1, i)
     NeSovp(2, 2, k1) = Tabl2(2, 2, i)
     NeSovp(2, 3, k1) = Tabl2(2, 3, i)
  End If
Next i
On Error Resume Next
Set WS = Sheets("Совпали")
If WS Is Nothing Then
   Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Совпали"
   Sheets(1).Rows(1).Copy Sheets("Совпали").Cells(1, 1)
Else
   WS.Cells.Clear
   Sheets(1).Rows(1).Copy Sheets("Совпали").Cells(1, 1)
End If
Set WS = Nothing
On Error Resume Next
Set WS = Sheets("Несовпали")
If WS Is Nothing Then
   Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Несовпали"
   Sheets(1).Rows(1).Copy Sheets("Несовпали").Cells(1, 1)
Else
   WS.Cells.Clear
   Sheets(1).Rows(1).Copy Sheets("Несовпали").Cells(1, 1)
End If
Worksheets(1).Range("A2:C2").Copy
With Worksheets("Совпали").Cells(1, 1).Resize(UBound(Sovp, 3), 3)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Rows.AutoFit
.Range(Cells(1, 1)).CurrentRegion.Sort Key1:=.Cells(1), Order1:=xlAscending, Orientation:=xlLeftToRight
End With
With Worksheets("Несовпали").Cells(1, 1).Resize(UBound(NeSovp, 3), 3)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Rows.AutoFit
.Range(Cells(1, 1)).CurrentRegion.Sort Key1:=.Cells(1), Order1:=xlAscending, Orientation:=xlLeftToRight
End With
For i = 1 To UBound(Sovp, 3)
  Worksheets("Совпали").Cells(i, 1) = Sovp(1, 1, i)
  Worksheets("Совпали").Cells(i, 2) = Sovp(1, 2, i)
  Worksheets("Совпали").Cells(i, 3) = Sovp(1, 3, i)
  Worksheets("Совпали").Cells(i, 1).Interior.Color = Sovp(2, 1, i)
  Worksheets("Совпали").Cells(i, 2).Interior.Color = Sovp(2, 2, i)
  Worksheets("Совпали").Cells(i, 3).Interior.Color = Sovp(2, 3, i)
Next i
For i = 1 To UBound(NeSovp, 3)
  Worksheets("Несовпали").Cells(i, 1) = NeSovp(1, 1, i)
  Worksheets("Несовпали").Cells(i, 2) = NeSovp(1, 2, i)
  Worksheets("Несовпали").Cells(i, 3) = NeSovp(1, 3, i)
  Worksheets("Несовпали").Cells(i, 1).Interior.Color = NeSovp(2, 1, i)
  Worksheets("Несовпали").Cells(i, 2).Interior.Color = NeSovp(2, 2, i)
  Worksheets("Несовпали").Cells(i, 3).Interior.Color = NeSovp(2, 3, i)
Next i
End Sub

[/vba]

К сообщению приложен файл: 3-.xls (56.0 Kb)

Много чего не знаю!!!!

Ответить

СообщениеAnnaKudrina, с копированием заливки, думаю, в реальном файле, макрос уже будет отрабатывать по времени не быстро.

[vba]

Код

Sub Sravn3()
Dim i As Long, i_n1 As Long
Dim Tabl1() As String, Tabl2() As String, Sovp() As String, NeSovp() As String, k1 As Long, kol As Long
Dim Obj1 As Object, Key1 As String
Dim WS As Worksheet
Set Obj1 = CreateObject("Scripting.dictionary")
i_n1 = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
ReDim Tabl1(2, 3, i_n1)
For i = 1 To i_n1
Tabl1(1, 1, i) = Trim(Worksheets(1).Cells(i, 1))
Tabl1(1, 2, i) = Trim(Worksheets(1).Cells(i, 2))
Tabl1(1, 3, i) = Trim(Worksheets(1).Cells(i, 3))
Tabl1(2, 1, i) = Worksheets(1).Cells(i, 1).Interior.Color
Tabl1(2, 2, i) = Worksheets(1).Cells(i, 2).Interior.Color
Tabl1(2, 3, i) = Worksheets(1).Cells(i, 3).Interior.Color
Next i
ReDim Sovp(2, 3, 1)
ReDim NeSovp(2, 3, 1)
Sovp(1, 1, 1) = Tabl1(1, 1, 1)
Sovp(1, 2, 1) = Tabl1(1, 2, 1)
Sovp(1, 3, 1) = Tabl1(1, 3, 1)
NeSovp(1, 1, 1) = Tabl1(1, 1, 1)
NeSovp(1, 2, 1) = Tabl1(1, 2, 1)
NeSovp(1, 3, 1) = Tabl1(1, 3, 1)
Sovp(2, 1, 1) = Tabl1(2, 1, 1)
Sovp(2, 2, 1) = Tabl1(2, 2, 1)
Sovp(2, 3, 1) = Tabl1(2, 3, 1)
NeSovp(2, 1, 1) = Tabl1(2, 1, 1)
NeSovp(2, 2, 1) = Tabl1(2, 2, 1)
NeSovp(2, 3, 1) = Tabl1(2, 3, 1)
ReDim Tabl2(2, 5, 1)
For i = 2 To i_n1
  Key1 = Tabl1(1, 1, i) & Tabl1(1, 2, i)
  If Not Obj1.exists(Key1) Then
     k1 = k1 + 1
     Obj1.Add Key1, CStr(k1)
     ReDim Preserve Tabl2(2, 5, k1)
     Tabl2(1, 1, k1) = Tabl1(1, 1, i)
     Tabl2(1, 2, k1) = Tabl1(1, 2, i)
     Tabl2(1, 3, k1) = Tabl1(1, 3, i)
     Tabl2(1, 4, k1) = 0
     Tabl2(2, 1, k1) = Tabl1(2, 1, i)
     Tabl2(2, 2, k1) = Tabl1(2, 2, i)
     Tabl2(2, 3, k1) = Tabl1(2, 3, i)
  End If
Next i
k1 = 1
k2 = 1
For i = 2 To i_n1
  Key1 = Tabl1(1, 1, i) & Tabl1(1, 2, i)
  If Obj1.exists(Key1) Then
     Tabl2(1, 4, Obj1(Key1)) = Tabl2(1, 4, Obj1(Key1)) + 1
  End If
Next i
For i = 1 To UBound(Tabl2, 3)
  If Tabl2(1, 4, i) > 1 Then
     k2 = k2 + 1
     ReDim Preserve Sovp(2, 3, k2)
     Sovp(1, 1, k2) = Tabl2(1, 1, i)
     Sovp(1, 2, k2) = Tabl2(1, 2, i)
     Sovp(1, 3, k2) = Tabl2(1, 3, i)
     Sovp(2, 1, k2) = Tabl2(2, 1, i)
     Sovp(2, 2, k2) = Tabl2(2, 2, i)
     Sovp(2, 3, k2) = Tabl2(2, 3, i)
  Else
     k1 = k1 + 1
     ReDim Preserve NeSovp(2, 3, k1)
     NeSovp(1, 1, k1) = Tabl2(1, 1, i)
     NeSovp(1, 2, k1) = Tabl2(1, 2, i)
     NeSovp(1, 3, k1) = Tabl2(1, 3, i)
     NeSovp(2, 1, k1) = Tabl2(2, 1, i)
     NeSovp(2, 2, k1) = Tabl2(2, 2, i)
     NeSovp(2, 3, k1) = Tabl2(2, 3, i)
  End If
Next i
On Error Resume Next
Set WS = Sheets("Совпали")
If WS Is Nothing Then
   Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Совпали"
   Sheets(1).Rows(1).Copy Sheets("Совпали").Cells(1, 1)
Else
   WS.Cells.Clear
   Sheets(1).Rows(1).Copy Sheets("Совпали").Cells(1, 1)
End If
Set WS = Nothing
On Error Resume Next
Set WS = Sheets("Несовпали")
If WS Is Nothing Then
   Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Несовпали"
   Sheets(1).Rows(1).Copy Sheets("Несовпали").Cells(1, 1)
Else
   WS.Cells.Clear
   Sheets(1).Rows(1).Copy Sheets("Несовпали").Cells(1, 1)
End If
Worksheets(1).Range("A2:C2").Copy
With Worksheets("Совпали").Cells(1, 1).Resize(UBound(Sovp, 3), 3)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Rows.AutoFit
.Range(Cells(1, 1)).CurrentRegion.Sort Key1:=.Cells(1), Order1:=xlAscending, Orientation:=xlLeftToRight
End With
With Worksheets("Несовпали").Cells(1, 1).Resize(UBound(NeSovp, 3), 3)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteColumnWidths
.Rows.AutoFit
.Range(Cells(1, 1)).CurrentRegion.Sort Key1:=.Cells(1), Order1:=xlAscending, Orientation:=xlLeftToRight
End With
For i = 1 To UBound(Sovp, 3)
  Worksheets("Совпали").Cells(i, 1) = Sovp(1, 1, i)
  Worksheets("Совпали").Cells(i, 2) = Sovp(1, 2, i)
  Worksheets("Совпали").Cells(i, 3) = Sovp(1, 3, i)
  Worksheets("Совпали").Cells(i, 1).Interior.Color = Sovp(2, 1, i)
  Worksheets("Совпали").Cells(i, 2).Interior.Color = Sovp(2, 2, i)
  Worksheets("Совпали").Cells(i, 3).Interior.Color = Sovp(2, 3, i)
Next i
For i = 1 To UBound(NeSovp, 3)
  Worksheets("Несовпали").Cells(i, 1) = NeSovp(1, 1, i)
  Worksheets("Несовпали").Cells(i, 2) = NeSovp(1, 2, i)
  Worksheets("Несовпали").Cells(i, 3) = NeSovp(1, 3, i)
  Worksheets("Несовпали").Cells(i, 1).Interior.Color = NeSovp(2, 1, i)
  Worksheets("Несовпали").Cells(i, 2).Interior.Color = NeSovp(2, 2, i)
  Worksheets("Несовпали").Cells(i, 3).Interior.Color = NeSovp(2, 3, i)
Next i
End Sub

[/vba]

Автор - Roman777
Дата добавления - 14.12.2015 в 09:59

Дата: Пятница, 22.12.2023, 10:06 | Сообщение № 20

Группа: Пользователи

Ранг: Прохожий

Сообщений: 1

Репутация: 0 ±

Замечаний: 0% ±

2007

Roman777, подскажите тоже проблема со сравнение столбцов, нужно сравнение по ФИО и диапазону дат, и вывести совпадения в отдельный лист и желательно с номером с другого столбца

Ответить

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос для сравнения нескольких столбцов таблицы (Макросы/Sub)

Страница 1 из 2
1
2
»

© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!