Здравствуйте. Подскажите, пожалуйста, как ещё можно сравнить 2 таблицы, и как упростить его сравнение? Есть определенные наработки. У меня есть 2 таблицы. Их нужно сравнить и выявить уникальные.
Проблема возникла сразу же, т.к. эти таблицы имеют разный вид данных, имеют повторы. 1таблица имеет вид сводной таблицы, имеет повторы внутри и всякие скобочки. 2таблица тоже имеет повторы, но без скобочек. Усложняется ситуация, что иногда эти таблицы порой бывают 1000человек, а то и больше. Возник вопрос автоматизма этого процесса.
Задача такая: нужно сравнить эти две таблицы.
Моя схема решения: 1. Достать данные из 1таблицы -> убрать лишнее(придать единый вид) -> объединить повторяющиеся -> переместить эти данные куда-то, где можно спокойно сравнить 2. Достать данные из 2таблицы сортировка по определенным столбцам -> объединить повторяющиеся -> придать единый вид -> переместить данные туда же, куда и итоговый результат по 1таблице. 3. Сравнить и выявить уникальные.
Что есть сейчас: Опытным и пробным путём сейчас я в ручную выделяю столбики(ФИО и количество) в 1таблице убираю лишнее по формуле(в 1 комментарии 1 документ), потом сводной таблицей достаю чистые ФИО и количество. Полученные данные снова забиваю в формулу, там есть другая, которая объединяет ФИО и кол-во. Потом это сохраняю на отдельный лист. По 2таблице мне приходится создавать копию документа, убирать лишние строки сверху, фильтровать по нужному мне столбику, потом зная сколько человек, добавляю столбик с кол-вом, ставлю везде 1. Потом сводной таблицей снова сливаю воедино повторы, потом вставляю в формулу для объединения ФИО и кол-ва, и вставляю в лист, где уже готовые данные по 1таблице. И только после этого я выбираю сравнить цветом, достаю уникальные данные.
Надеюсь вы поняли о чём я : )) Хочу ваше экспертное мнение, как это всё можно упростить, чтобы не было так сложно. Я бы хотел просто вставлять данные на 1 листе по 1 и по 2 таблице, и в новом листе уже иметь готовую таблицу для сравнения. Можно ли так сделать, без этого танца с бубном?
Я перелопатил интернет, и постоянно приходится урывками находить такие вот методы. Моих знаний уже не достаточно.
Написал сюда, т.к. понимаю, что мою задачу можно решить только макросом, который автоматически сделает за меня эти магические комбинации нажимая кнопку.
Прошу помочь с данным вопросом. Буду вам очень благодарен!
PS Сюда прикрепил таблицы. В комментарии прикреплю данные со своими наработками.
Здравствуйте. Подскажите, пожалуйста, как ещё можно сравнить 2 таблицы, и как упростить его сравнение? Есть определенные наработки. У меня есть 2 таблицы. Их нужно сравнить и выявить уникальные.
Проблема возникла сразу же, т.к. эти таблицы имеют разный вид данных, имеют повторы. 1таблица имеет вид сводной таблицы, имеет повторы внутри и всякие скобочки. 2таблица тоже имеет повторы, но без скобочек. Усложняется ситуация, что иногда эти таблицы порой бывают 1000человек, а то и больше. Возник вопрос автоматизма этого процесса.
Задача такая: нужно сравнить эти две таблицы.
Моя схема решения: 1. Достать данные из 1таблицы -> убрать лишнее(придать единый вид) -> объединить повторяющиеся -> переместить эти данные куда-то, где можно спокойно сравнить 2. Достать данные из 2таблицы сортировка по определенным столбцам -> объединить повторяющиеся -> придать единый вид -> переместить данные туда же, куда и итоговый результат по 1таблице. 3. Сравнить и выявить уникальные.
Что есть сейчас: Опытным и пробным путём сейчас я в ручную выделяю столбики(ФИО и количество) в 1таблице убираю лишнее по формуле(в 1 комментарии 1 документ), потом сводной таблицей достаю чистые ФИО и количество. Полученные данные снова забиваю в формулу, там есть другая, которая объединяет ФИО и кол-во. Потом это сохраняю на отдельный лист. По 2таблице мне приходится создавать копию документа, убирать лишние строки сверху, фильтровать по нужному мне столбику, потом зная сколько человек, добавляю столбик с кол-вом, ставлю везде 1. Потом сводной таблицей снова сливаю воедино повторы, потом вставляю в формулу для объединения ФИО и кол-ва, и вставляю в лист, где уже готовые данные по 1таблице. И только после этого я выбираю сравнить цветом, достаю уникальные данные.
Надеюсь вы поняли о чём я : )) Хочу ваше экспертное мнение, как это всё можно упростить, чтобы не было так сложно. Я бы хотел просто вставлять данные на 1 листе по 1 и по 2 таблице, и в новом листе уже иметь готовую таблицу для сравнения. Можно ли так сделать, без этого танца с бубном?
Я перелопатил интернет, и постоянно приходится урывками находить такие вот методы. Моих знаний уже не достаточно.
Написал сюда, т.к. понимаю, что мою задачу можно решить только макросом, который автоматически сделает за меня эти магические комбинации нажимая кнопку.
Прошу помочь с данным вопросом. Буду вам очень благодарен!
PS Сюда прикрепил таблицы. В комментарии прикреплю данные со своими наработками.BTH
Да, вот примерно так должно быть в итоге. Лист "Итого" На этом листе я применяю функцию "Условное форматирование"-"Правила выделения ячеек"-"Повторяющиеся значения". Я только такой путь нашел самый легкий нахождения разных показателей. + было неудобно сравнивать. Я добавил возможность объединения ФИО и кол-ва, чтобы ~Петрович2 и ~Петрович1 были разные показатели.
Да, вот примерно так должно быть в итоге. Лист "Итого" На этом листе я применяю функцию "Условное форматирование"-"Правила выделения ячеек"-"Повторяющиеся значения". Я только такой путь нашел самый легкий нахождения разных показателей. + было неудобно сравнивать. Я добавил возможность объединения ФИО и кол-ва, чтобы ~Петрович2 и ~Петрович1 были разные показатели.BTH
я же про пути не спрашивал) а что получить хотите) убрать скобочки-посчитать повторы-добавить количество повторов к фио - покрасить без совпадений, я правильно понял задачу? в первой табличке количество изначально дано, а во второй подсчет фио, правильно?
я же про пути не спрашивал) а что получить хотите) убрать скобочки-посчитать повторы-добавить количество повторов к фио - покрасить без совпадений, я правильно понял задачу? в первой табличке количество изначально дано, а во второй подсчет фио, правильно?sboy
Излишнее цитирование удалено администрацией - это нарушение п.5j Правил форума
Да, всё верно Да, во второй таблице изначально нет столбика "кол-во". Необходимо как-то повторы тоже подсчитать и вывести количество. Только не весь столбик, а только определенный пул ФИО (т.к. я применяю там алфавитный фильтр нужного столбца + ФИО).
Излишнее цитирование удалено администрацией - это нарушение п.5j Правил форума
Да, всё верно Да, во второй таблице изначально нет столбика "кол-во". Необходимо как-то повторы тоже подсчитать и вывести количество. Только не весь столбик, а только определенный пул ФИО (т.к. я применяю там алфавитный фильтр нужного столбца + ФИО).BTH
BlackTeaHappy
Сообщение отредактировал BTH - Среда, 04.10.2017, 14:50
Добрый день. Копируем данные в соответствующие столбцы, нажимаем кнопку [vba]
Код
Sub tabl1() Dim arr_() c = 1 For t = 1 To 2 lr = Cells(Rows.Count, c).End(xlUp).Row Set oDict = CreateObject("Scripting.Dictionary") With oDict For r = 2 To lr q = InStr(1, Cells(r, c).Value, "(", vbTextCompare) If q Then fio = Left(Cells(r, c).Value, q - 2) Else: fio = Cells(r, c).Value End If Select Case t Case 1 If .exists(fio) Then .Item(fio) = .Item(fio) + Cells(r, c + 1).Value Else: .Add fio, Cells(r, c + 1).Value End If Case 2 If Not .exists(fio) Then .Add fio, WorksheetFunction.CountIf(Range(Cells(2, c), Cells(lr, c)), fio) End If End Select Next r keysArr = .keys itemsArr = .items ReDim arr_(1 To .Count) For x = 0 To UBound(keysArr) arr_(x + 1) = keysArr(x) & itemsArr(x) Next x End With Sheets("Итого").Cells(2, t).Resize(UBound(arr_), 1) = Application.Transpose(arr_) c = 4 Set oDict = Nothing ReDim arr_(0) Next t Sheets("Итого").Activate End Sub
Добрый день. Копируем данные в соответствующие столбцы, нажимаем кнопку [vba]
Код
Sub tabl1() Dim arr_() c = 1 For t = 1 To 2 lr = Cells(Rows.Count, c).End(xlUp).Row Set oDict = CreateObject("Scripting.Dictionary") With oDict For r = 2 To lr q = InStr(1, Cells(r, c).Value, "(", vbTextCompare) If q Then fio = Left(Cells(r, c).Value, q - 2) Else: fio = Cells(r, c).Value End If Select Case t Case 1 If .exists(fio) Then .Item(fio) = .Item(fio) + Cells(r, c + 1).Value Else: .Add fio, Cells(r, c + 1).Value End If Case 2 If Not .exists(fio) Then .Add fio, WorksheetFunction.CountIf(Range(Cells(2, c), Cells(lr, c)), fio) End If End Select Next r keysArr = .keys itemsArr = .items ReDim arr_(1 To .Count) For x = 0 To UBound(keysArr) arr_(x + 1) = keysArr(x) & itemsArr(x) Next x End With Sheets("Итого").Cells(2, t).Resize(UBound(arr_), 1) = Application.Transpose(arr_) c = 4 Set oDict = Nothing ReDim arr_(0) Next t Sheets("Итого").Activate End Sub
Пара вопросов 1. почто ячейки столбца А не из массива к словарь кладутся, а с листа каждый раз в цикле берутся вот здесь[vba]
Код
q = InStr(Cells(r, c).Value, "(")
[/vba] - кол-во обращений к листу по возможности нужно минимизировать, поэтому сначала все данные загоняем в массив, а потом из него в словарь
2. создаем массив keysArr (и itemsArr тоже) и приравниваем его массиву .keys? Получили 2 совершенно одинаковых массива. Зачем? объединять ФИО и кол-во можно прямо сразу в Итеме (через разделитель, например "|") и потом Сплитом разделять, а можно после создания словаря переписать его с Итемом, равным Кейс & Итем, примерно вот так [vba]
Код
Next r 'отсюда For Each k_ In .Keys .Item(k_) = k_ & " - " & .Item(k_) Next Sheets("Итого").Cells(2, t).Resize(.Count) = Application.Transpose(.Items) 'досюда c = 4
[/vba]
Пока писал текст, Лена уже послала. Впрочем, у меня примерно также написано было - "новую тему"
Пара вопросов 1. почто ячейки столбца А не из массива к словарь кладутся, а с листа каждый раз в цикле берутся вот здесь[vba]
Код
q = InStr(Cells(r, c).Value, "(")
[/vba] - кол-во обращений к листу по возможности нужно минимизировать, поэтому сначала все данные загоняем в массив, а потом из него в словарь
2. создаем массив keysArr (и itemsArr тоже) и приравниваем его массиву .keys? Получили 2 совершенно одинаковых массива. Зачем? объединять ФИО и кол-во можно прямо сразу в Итеме (через разделитель, например "|") и потом Сплитом разделять, а можно после создания словаря переписать его с Итемом, равным Кейс & Итем, примерно вот так [vba]
Код
Next r 'отсюда For Each k_ In .Keys .Item(k_) = k_ & " - " & .Item(k_) Next Sheets("Итого").Cells(2, t).Resize(.Count) = Application.Transpose(.Items) 'досюда c = 4
_Boroda_, Спасибо за помощь в обучении по 1 - принято, в извилину добавлено) по 2 - не додумал до For each... не знал как пройтись циклом по ключам, т.к. у них нет номера, поэтому перегнал в массив
_Boroda_, Спасибо за помощь в обучении по 1 - принято, в извилину добавлено) по 2 - не додумал до For each... не знал как пройтись циклом по ключам, т.к. у них нет номера, поэтому перегнал в массивsboy
Sub tabl1() c = 1 For t = 1 To 2 lr = Cells(Rows.Count, c).End(xlUp).Row fioArr = Range(Cells(2, c), Cells(lr, c + 1)).Value Set oDict = CreateObject("Scripting.Dictionary") With oDict For r = 1 To UBound(fioArr) q = InStr(1, fioArr(r, 1), "(", vbTextCompare) If q Then fio = Left(fioArr(r, 1), q - 2) Else: fio = fioArr(r, 1) End If Select Case t Case 1 If .exists(fio) Then .Item(fio) = .Item(fio) + fioArr(r, 2) Else: .Add fio, fioArr(r, 2) End If Case 2 If Not .exists(fio) Then countfio = 0 For x = 1 To UBound(fioArr) If fioArr(x, 1) = fioArr(r, 1) Then countfio = countfio + 1 Next x .Add fio, countfio End If End Select Next r For Each k In .keys .Item(k) = k & .Item(k) Next k Sheets("Итого").Cells(2, t).Resize(.Count, 1) = Application.Transpose(.items) End With c = 4 Set oDict = Nothing fioArr = Empty Next t Sheets("Итого").Activate End Sub
[/vba]
С учетом вышесказанного, вот так получилось [vba]
Код
Sub tabl1() c = 1 For t = 1 To 2 lr = Cells(Rows.Count, c).End(xlUp).Row fioArr = Range(Cells(2, c), Cells(lr, c + 1)).Value Set oDict = CreateObject("Scripting.Dictionary") With oDict For r = 1 To UBound(fioArr) q = InStr(1, fioArr(r, 1), "(", vbTextCompare) If q Then fio = Left(fioArr(r, 1), q - 2) Else: fio = fioArr(r, 1) End If Select Case t Case 1 If .exists(fio) Then .Item(fio) = .Item(fio) + fioArr(r, 2) Else: .Add fio, fioArr(r, 2) End If Case 2 If Not .exists(fio) Then countfio = 0 For x = 1 To UBound(fioArr) If fioArr(x, 1) = fioArr(r, 1) Then countfio = countfio + 1 Next x .Add fio, countfio End If End Select Next r For Each k In .keys .Item(k) = k & .Item(k) Next k Sheets("Итого").Cells(2, t).Resize(.Count, 1) = Application.Transpose(.items) End With c = 4 Set oDict = Nothing fioArr = Empty Next t Sheets("Итого").Activate End Sub
Попробовал. У меня как-то медленнее работает вторая версия кода(за 6 секунд). Это нормально?) Первая версия за 2,40 секунд. Но выдаёт всё так же отличный результат! Спасибо!
Попробовал. У меня как-то медленнее работает вторая версия кода(за 6 секунд). Это нормально?) Первая версия за 2,40 секунд. Но выдаёт всё так же отличный результат! Спасибо!BTH
BlackTeaHappy
Сообщение отредактировал BTH - Пятница, 06.10.2017, 07:49
я так думаю, что функция листа в первом коде [vba]
Код
If Not .exists(fio) Then .Add fio, WorksheetFunction.CountIf(Range(Cells(2, c), Cells(lr, c)), fio) End If
[/vba] отрабатывает быстрее, чем перебор в цикле все элементов массива во втором коде [vba]
Код
If Not .exists(fio) Then countfio = 0 For x = 1 To UBound(fioArr) If fioArr(x, 1) = fioArr(r, 1) Then countfio = countfio + 1 Next x .Add fio, countfio
я так думаю, что функция листа в первом коде [vba]
Код
If Not .exists(fio) Then .Add fio, WorksheetFunction.CountIf(Range(Cells(2, c), Cells(lr, c)), fio) End If
[/vba] отрабатывает быстрее, чем перебор в цикле все элементов массива во втором коде [vba]
Код
If Not .exists(fio) Then countfio = 0 For x = 1 To UBound(fioArr) If fioArr(x, 1) = fioArr(r, 1) Then countfio = countfio + 1 Next x .Add fio, countfio
А вот еще вариант протестируйте. Интересно Прошлый макрос не совсем верный был. Перевложил [vba]
Код
Sub tt() Application.ScreenUpdating = 0 Application.Calculation = xlCalculationManual 'если данные нельзя портить, то раскомментируйте строки *** r11_ = Range("A" & Rows.Count).End(3).Row - 1 'последняя строка r12_ = Range("D" & Rows.Count).End(3).Row - 1 ' ar10 = Range("A2").Resize(r11_, 2) '***значения в массив ' ar20 = Range("D2").Resize(r12_) '*** Range("A2").Resize(r11_ + 1).Replace What:=" (*", Replacement:="" 'меняем пробел-скобка и все, что после них на ничего Range("D2").Resize(r12_ + 1).Replace What:=" (*", Replacement:="" ar11 = Range("A2").Resize(r11_, 2) 'значения в массив ar21 = Range("D2").Resize(r12_) ' Range("A2").Resize(r11_, 2) = ar10 '***восстанавливаем как было ' Range("D2").Resize(r12_) = ar20 '*** Set slov = CreateObject("Scripting.Dictionary") With slov For i = 1 To r11_ .Item(ar11(i, 1)) = ar11(i, 2) + .Item(ar11(i, 1)) Next i For Each k_ In .Keys .Item(k_) = k_ & " - " & .Item(k_) Next Sheets("Итого").Cells(2, 1).Resize(.Count) = Application.Transpose(.Items) .RemoveAll For i = 1 To r12_ .Item(ar21(i, 1)) = 1 + .Item(ar21(i, 1)) Next i For Each k_ In .Keys .Item(k_) = k_ & " - " & .Item(k_) Next Sheets("Итого").Cells(2, 2).Resize(.Count) = Application.Transpose(.Items) End With Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = 1 Sheets("Итого").Activate End Sub
[/vba]
А вот еще вариант протестируйте. Интересно Прошлый макрос не совсем верный был. Перевложил [vba]
Код
Sub tt() Application.ScreenUpdating = 0 Application.Calculation = xlCalculationManual 'если данные нельзя портить, то раскомментируйте строки *** r11_ = Range("A" & Rows.Count).End(3).Row - 1 'последняя строка r12_ = Range("D" & Rows.Count).End(3).Row - 1 ' ar10 = Range("A2").Resize(r11_, 2) '***значения в массив ' ar20 = Range("D2").Resize(r12_) '*** Range("A2").Resize(r11_ + 1).Replace What:=" (*", Replacement:="" 'меняем пробел-скобка и все, что после них на ничего Range("D2").Resize(r12_ + 1).Replace What:=" (*", Replacement:="" ar11 = Range("A2").Resize(r11_, 2) 'значения в массив ar21 = Range("D2").Resize(r12_) ' Range("A2").Resize(r11_, 2) = ar10 '***восстанавливаем как было ' Range("D2").Resize(r12_) = ar20 '*** Set slov = CreateObject("Scripting.Dictionary") With slov For i = 1 To r11_ .Item(ar11(i, 1)) = ar11(i, 2) + .Item(ar11(i, 1)) Next i For Each k_ In .Keys .Item(k_) = k_ & " - " & .Item(k_) Next Sheets("Итого").Cells(2, 1).Resize(.Count) = Application.Transpose(.Items) .RemoveAll For i = 1 To r12_ .Item(ar21(i, 1)) = 1 + .Item(ar21(i, 1)) Next i For Each k_ In .Keys .Item(k_) = k_ & " - " & .Item(k_) Next Sheets("Итого").Cells(2, 2).Resize(.Count) = Application.Transpose(.Items) End With Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = 1 Sheets("Итого").Activate End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
