Добрый вечер.Есть три таблицы и макрос,сравнивающий две таблицы по одинаковым строкам.Как изменить(дополнить) макрос,чтобы сравнение происходило по трем таблицам.
Добрый вечер.Есть три таблицы и макрос,сравнивающий две таблицы по одинаковым строкам.Как изменить(дополнить) макрос,чтобы сравнение происходило по трем таблицам.megavlom
Sub ertert() 'вторая версия Dim aRef, a, x, y(), i&, s$, t, dic As Object Set dic = CreateObject("Scripting.Dictionary"): dic.CompareMode = 1
aRef = Array(Sheets(1).[a3], Sheets(1).[d3], Sheets(1).[g3]) On Error Resume Next For Each a In aRef x = a.CurrentRegion.Value With New Collection For i = 1 To UBound(x) s = x(i, 1) & "|" & x(i, 2) If IsEmpty(.Item(s)) Then .Add s, s Next i For i = 1 To .Count s = .Item(i) If dic.Exists(s) Then dic.Item(s) = dic.Item(s) + 1 Else dic.Item(s) = 1 Next i End With Next a: On Error GoTo 0
ReDim y(1 To dic.Count, 1 To 2): i = 0 For Each a In dic.Keys If dic.Item(a) = 3 Then t = Split(a, "|"): i = i + 1: y(i, 1) = t(0): y(i, 2) = t(1) Next a
If i > 0 Then Sheets(1).[j3:k3].Resize(i) = y Set dic = Nothing End Sub
[/vba] Если Sheets(1) активный, то ссылку на него можно убрать.
Так как-то: [vba]
Код
Sub ertert() 'вторая версия Dim aRef, a, x, y(), i&, s$, t, dic As Object Set dic = CreateObject("Scripting.Dictionary"): dic.CompareMode = 1
aRef = Array(Sheets(1).[a3], Sheets(1).[d3], Sheets(1).[g3]) On Error Resume Next For Each a In aRef x = a.CurrentRegion.Value With New Collection For i = 1 To UBound(x) s = x(i, 1) & "|" & x(i, 2) If IsEmpty(.Item(s)) Then .Add s, s Next i For i = 1 To .Count s = .Item(i) If dic.Exists(s) Then dic.Item(s) = dic.Item(s) + 1 Else dic.Item(s) = 1 Next i End With Next a: On Error GoTo 0
ReDim y(1 To dic.Count, 1 To 2): i = 0 For Each a In dic.Keys If dic.Item(a) = 3 Then t = Split(a, "|"): i = i + 1: y(i, 1) = t(0): y(i, 2) = t(1) Next a
If i > 0 Then Sheets(1).[j3:k3].Resize(i) = y Set dic = Nothing End Sub
[/vba] Если Sheets(1) активный, то ссылку на него можно убрать.nilem
Яндекс.Деньги 4100159601573
Сообщение отредактировал nilem - Вторник, 06.09.2011, 09:28
Я предлагаю такую поправку в твою первую версию на словаре: [vba]
Код
Sub ert() Dim aRef, a, x, y(), i&, j&, s$, t, ind&, st$ aRef = Array(Sheets(1).[a3], Sheets(1).[d3], Sheets(1).[g3]) With CreateObject("Scripting.Dictionary") .CompareMode = 1 For Each a In aRef x = a.CurrentRegion.Value ind = ind + 1 For i = 1 To UBound(x) s = x(i, 1) & "|" & x(i, 2) If .Exists(s) Then st = .Item(s) Mid(st, ind) = ind .Item(s) = st Else st = "000" Mid(st, ind) = ind .Item(s) = st End If Next i Next a ReDim y(1 To .Count, 1 To 2) For Each a In .Keys If .Item(a) = "123" Then t = Split(a, "|"): j = j + 1: y(j, 1) = t(0): y(j, 2) = t(1) Next a End With Sheets(1).[j3:k3].Resize(j) = y End Sub
[/vba]
Даже так - изначально st задать таким образом, будет универсальнее: [vba]
Код
st = String(UBound(aRef) + 1, "0")
[/vba] и тогда ещё в конце проверку сделать так: [vba]
Код
ReDim y(1 To .Count, 1 To 2) st = "" For i = 0 To UBound(aRef): st = st & i + 1: Next For Each a In .Keys If .Item(a) = st Then t = Split(a, "|"): j = j + 1: y(j, 1) = t(0): y(j, 2) = t(1) Next a
[/vba]
Я предлагаю такую поправку в твою первую версию на словаре: [vba]
Код
Sub ert() Dim aRef, a, x, y(), i&, j&, s$, t, ind&, st$ aRef = Array(Sheets(1).[a3], Sheets(1).[d3], Sheets(1).[g3]) With CreateObject("Scripting.Dictionary") .CompareMode = 1 For Each a In aRef x = a.CurrentRegion.Value ind = ind + 1 For i = 1 To UBound(x) s = x(i, 1) & "|" & x(i, 2) If .Exists(s) Then st = .Item(s) Mid(st, ind) = ind .Item(s) = st Else st = "000" Mid(st, ind) = ind .Item(s) = st End If Next i Next a ReDim y(1 To .Count, 1 To 2) For Each a In .Keys If .Item(a) = "123" Then t = Split(a, "|"): j = j + 1: y(j, 1) = t(0): y(j, 2) = t(1) Next a End With Sheets(1).[j3:k3].Resize(j) = y End Sub
[/vba]
Даже так - изначально st задать таким образом, будет универсальнее: [vba]
Код
st = String(UBound(aRef) + 1, "0")
[/vba] и тогда ещё в конце проверку сделать так: [vba]
Код
ReDim y(1 To .Count, 1 To 2) st = "" For i = 0 To UBound(aRef): st = st & i + 1: Next For Each a In .Keys If .Item(a) = st Then t = Split(a, "|"): j = j + 1: y(j, 1) = t(0): y(j, 2) = t(1) Next a
Могу пояснить код Николая (с моей добавкой) Перебором всех таблиц помещаем в словарь данные/значения (через разделитель"|"), в Item каждому значению кладём строку вида "000", где вместо каждого 0 будет номер таблицы, где это значение встретилось (можно вместо номера просто 1 ставить, не принципиально). Повтор значения внутри таблицы просто переписывает этот Item в том же виде. В итоге проверяем, если у значения в Item заполнены все позиции - значит это значение было во всех 3-х таблицах. Моя коррекция ниже даёт динамику - таблиц может быть много, соответственно эта строка "0000..." будет формироваться по количеству таблиц. Итоговой проверкой можно определить, в каких таблицах значение встречалось. Т.е. может пригодиться и такой функционал - например, зная значение, получить список таблиц с этим значением.
Могу пояснить код Николая (с моей добавкой) Перебором всех таблиц помещаем в словарь данные/значения (через разделитель"|"), в Item каждому значению кладём строку вида "000", где вместо каждого 0 будет номер таблицы, где это значение встретилось (можно вместо номера просто 1 ставить, не принципиально). Повтор значения внутри таблицы просто переписывает этот Item в том же виде. В итоге проверяем, если у значения в Item заполнены все позиции - значит это значение было во всех 3-х таблицах. Моя коррекция ниже даёт динамику - таблиц может быть много, соответственно эта строка "0000..." будет формироваться по количеству таблиц. Итоговой проверкой можно определить, в каких таблицах значение встречалось. Т.е. может пригодиться и такой функционал - например, зная значение, получить список таблиц с этим значением.Hugo
ОТЛИЧНО!Теперь с пояснениями может пригодиться не только мне.Данный макрос может использоваться как "расширенный фильтр" для любого количества столбцов,не обязательно таблиц.А вообще большое Вам спасибо за коментарии в макросах,(и не только на этом сайте).Кто хочет,тот по ним учится и приспосабливает для своих задач.Ещё раз Всем Спасибо.
ОТЛИЧНО!Теперь с пояснениями может пригодиться не только мне.Данный макрос может использоваться как "расширенный фильтр" для любого количества столбцов,не обязательно таблиц.А вообще большое Вам спасибо за коментарии в макросах,(и не только на этом сайте).Кто хочет,тот по ним учится и приспосабливает для своих задач.Ещё раз Всем Спасибо.megavlom
Или вот такая модификация кода Николая - выведет все уникальные позиции с кодом в третьем столбце, по которому можно выяснить, где и сколько раз эта позиция встречалась, например Мира, 15-Ленина 14 Иванов ИП 120 1 раз в первой, 2 во второй, 0 в третьей. Наличие нуля указывает на то, что эта позиция была не во всех таблицах - по этому признаку можно отобрать нужные.
[vba]
Код
Sub ert() Dim aRef, a, x, y(), i&, j&, s$, t, ind& aRef = Array(Sheets(1).[a3], Sheets(1).[d3], Sheets(1).[g3]) With CreateObject("Scripting.Dictionary") .CompareMode = 1 For Each a In aRef x = a.CurrentRegion.Value ind = ind + 1 For i = 1 To UBound(x) s = x(i, 1) & "|" & x(i, 2) If .Exists(s) Then st = .Item(s) Mid(st, ind) = --Mid(st, ind, 1) + 1 .Item(s) = st Else st = String(UBound(aRef) + 1, "0") Mid(st, ind) = 1 .Item(s) = st End If Next i Next a ReDim y(1 To .Count, 1 To 3) For Each a In .Keys t = Split(a, "|"): j = j + 1: y(j, 1) = t(0): y(j, 2) = t(1): y(j, 3) = .Item(a) Next a End With With Sheets(1).[j3:l3].Resize(j) .NumberFormat = "@" .Value = y End With End Sub
[/vba]
Или вот такая модификация кода Николая - выведет все уникальные позиции с кодом в третьем столбце, по которому можно выяснить, где и сколько раз эта позиция встречалась, например Мира, 15-Ленина 14 Иванов ИП 120 1 раз в первой, 2 во второй, 0 в третьей. Наличие нуля указывает на то, что эта позиция была не во всех таблицах - по этому признаку можно отобрать нужные.
[vba]
Код
Sub ert() Dim aRef, a, x, y(), i&, j&, s$, t, ind& aRef = Array(Sheets(1).[a3], Sheets(1).[d3], Sheets(1).[g3]) With CreateObject("Scripting.Dictionary") .CompareMode = 1 For Each a In aRef x = a.CurrentRegion.Value ind = ind + 1 For i = 1 To UBound(x) s = x(i, 1) & "|" & x(i, 2) If .Exists(s) Then st = .Item(s) Mid(st, ind) = --Mid(st, ind, 1) + 1 .Item(s) = st Else st = String(UBound(aRef) + 1, "0") Mid(st, ind) = 1 .Item(s) = st End If Next i Next a ReDim y(1 To .Count, 1 To 3) For Each a In .Keys t = Split(a, "|"): j = j + 1: y(j, 1) = t(0): y(j, 2) = t(1): y(j, 3) = .Item(a) Next a End With With Sheets(1).[j3:l3].Resize(j) .NumberFormat = "@" .Value = y End With End Sub
Hugo, если не сложно, как будет выглядить макрос для сравнения двух таблиц на разных листах в сравнении по указаным столбцам? [moder]Читаем Правила форума, создаём свою тему, прикладываем файл с примером. Эта тема закрыта[/moder]
Hugo, если не сложно, как будет выглядить макрос для сравнения двух таблиц на разных листах в сравнении по указаным столбцам? [moder]Читаем Правила форума, создаём свою тему, прикладываем файл с примером. Эта тема закрыта[/moder]Ukh
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
