Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

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

 

= Мир MS Excel/Макрос, сравнивающий списки в разных столбцах на совпадение - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос, сравнивающий списки в разных столбцах на совпадение (Макросы/Sub)
Макрос, сравнивающий списки в разных столбцах на совпадение
Leviven Дата: Вторник, 21.07.2020, 12:17 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 38
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Добрый день, форумчане! Макросы в Модуле2 производят сравнение списка из столбца "B" поочередно со столбцами "I", "J" и "K", выводя поочередно списки в дополнительные столбцы: "L", "M" и "N", убирая одинаковые фамилии. Затем результат заносится в итоговый столбец "Z" (Состоит больных).
В принципе, все работает, макросы поочередно запускают друг друга, но...как-то громоздко получается. Идет сравнение только двух списков в одном макросе. По-другому у меня не получилось.
В связи с этим вопрос: можно ли обойтись без дополнительных столбцов - "L", "M" и "N" и кучи макросов и выполнить напрямую сравнение списка из столбца "B" со столбцами "I", "J" и "K" на совпадения и занести уникальный результат сразу в итоговый столбец "Z" одним макросом? Пример прилагаю.
К сообщению приложен файл: 0314115.xls(97.5 Kb)
 
Ответить
СообщениеДобрый день, форумчане! Макросы в Модуле2 производят сравнение списка из столбца "B" поочередно со столбцами "I", "J" и "K", выводя поочередно списки в дополнительные столбцы: "L", "M" и "N", убирая одинаковые фамилии. Затем результат заносится в итоговый столбец "Z" (Состоит больных).
В принципе, все работает, макросы поочередно запускают друг друга, но...как-то громоздко получается. Идет сравнение только двух списков в одном макросе. По-другому у меня не получилось.
В связи с этим вопрос: можно ли обойтись без дополнительных столбцов - "L", "M" и "N" и кучи макросов и выполнить напрямую сравнение списка из столбца "B" со столбцами "I", "J" и "K" на совпадения и занести уникальный результат сразу в итоговый столбец "Z" одним макросом? Пример прилагаю.

Автор - Leviven
Дата добавления - 21.07.2020 в 12:17
Hugo Дата: Вторник, 21.07.2020, 12:56 | Сообщение № 2
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3133
Репутация: 670 ±
Замечаний: 0% ±

2010, теперь уже с PQ
Добрый день.
Там ещё и первый модуль своё добавляет.
Делайте на коллекции или словаре - будет проще и быстрее.
Сперва собираете в объект всех поступивших, затем удаляете выбывших, остаток выгружаете.
Но вот как Вы будете решать проблему Ивановых - мне по примеру непонятно, поэтому я пока не участвую :)


excel@nxt.ru
webmoney: R418926282008 Z422237915069
 
Ответить
СообщениеДобрый день.
Там ещё и первый модуль своё добавляет.
Делайте на коллекции или словаре - будет проще и быстрее.
Сперва собираете в объект всех поступивших, затем удаляете выбывших, остаток выгружаете.
Но вот как Вы будете решать проблему Ивановых - мне по примеру непонятно, поэтому я пока не участвую :)

Автор - Hugo
Дата добавления - 21.07.2020 в 12:56
Hugo Дата: Вторник, 21.07.2020, 13:11 | Сообщение № 3
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3133
Репутация: 670 ±
Замечаний: 0% ±

2010, теперь уже с PQ
Хотя вот, сделал. Работает пока нет однофамильцев!



Тут нет защиты не только от повторов, но и от дураков. Т.е. когда Иванов не состоял, не поступал, но вдруг выбывает...


excel@nxt.ru
webmoney: R418926282008 Z422237915069


Сообщение отредактировал Hugo - Вторник, 21.07.2020, 14:23
 
Ответить
СообщениеХотя вот, сделал. Работает пока нет однофамильцев!



Тут нет защиты не только от повторов, но и от дураков. Т.е. когда Иванов не состоял, не поступал, но вдруг выбывает...

Автор - Hugo
Дата добавления - 21.07.2020 в 13:11
Leviven Дата: Вторник, 21.07.2020, 13:46 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 38
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Hugo, премного благодарю. Работает до определенного предела.[vba]
Код
Sub tt()
    Dim col As New Collection
    Dim a, i&, t$

    'добавляем
    a = ActiveSheet.UsedRange.Columns(2).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) Then col.Add t, t
    Next
    a = ActiveSheet.UsedRange.Columns(3).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) Then col.Add t, t
    Next
    a = ActiveSheet.UsedRange.Columns(22).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) > 1 Then col.Add t, t
    Next
    a = ActiveSheet.UsedRange.Columns(23).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) > 1 Then col.Add t, t
    Next
    a = ActiveSheet.UsedRange.Columns(24).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) > 1 Then col.Add t, t
    Next
    a = ActiveSheet.UsedRange.Columns(25).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) > 1 Then col.Add t, t
    Next

    'убираем
    a = ActiveSheet.UsedRange.Columns(4).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) Then col.Remove t
    Next
    a = ActiveSheet.UsedRange.Columns(5).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) Then col.Remove t
    Next
    a = ActiveSheet.UsedRange.Columns(6).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) Then col.Remove t
    Next
    a = ActiveSheet.UsedRange.Columns(7).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) Then col.Remove t
    Next

    a = ActiveSheet.UsedRange.Columns(9).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) Then col.Remove t
    Next
    a = ActiveSheet.UsedRange.Columns(10).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) Then col.Remove t
    Next
    a = ActiveSheet.UsedRange.Columns(11).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) Then col.Remove t
    Next

    'перекладываем в массив
    ReDim a(1 To col.Count, 1 To 1)
    For i = 1 To col.Count
        a(i, 1) = col(i)
    Next
    'выгрузка на лист
    [z5].Resize(UBound(a), 1) = a

End Sub
[/vba]

А вот когда между 7 и 9 столбцом попробовал вставить еще и 8-й:[vba]
Код
a = ActiveSheet.UsedRange.Columns(8).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) Then col.Remove t
    Next
[/vba]
то сразу макрос стопориться в отладку и подсвечивает col.Remove t. Там что, лимит строк стоит? 8-я строчка из "убираем" тоже нужна
 
Ответить
СообщениеHugo, премного благодарю. Работает до определенного предела.[vba]
Код
Sub tt()
    Dim col As New Collection
    Dim a, i&, t$

    'добавляем
    a = ActiveSheet.UsedRange.Columns(2).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) Then col.Add t, t
    Next
    a = ActiveSheet.UsedRange.Columns(3).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) Then col.Add t, t
    Next
    a = ActiveSheet.UsedRange.Columns(22).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) > 1 Then col.Add t, t
    Next
    a = ActiveSheet.UsedRange.Columns(23).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) > 1 Then col.Add t, t
    Next
    a = ActiveSheet.UsedRange.Columns(24).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) > 1 Then col.Add t, t
    Next
    a = ActiveSheet.UsedRange.Columns(25).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) > 1 Then col.Add t, t
    Next

    'убираем
    a = ActiveSheet.UsedRange.Columns(4).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) Then col.Remove t
    Next
    a = ActiveSheet.UsedRange.Columns(5).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) Then col.Remove t
    Next
    a = ActiveSheet.UsedRange.Columns(6).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) Then col.Remove t
    Next
    a = ActiveSheet.UsedRange.Columns(7).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) Then col.Remove t
    Next

    a = ActiveSheet.UsedRange.Columns(9).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) Then col.Remove t
    Next
    a = ActiveSheet.UsedRange.Columns(10).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) Then col.Remove t
    Next
    a = ActiveSheet.UsedRange.Columns(11).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) Then col.Remove t
    Next

    'перекладываем в массив
    ReDim a(1 To col.Count, 1 To 1)
    For i = 1 To col.Count
        a(i, 1) = col(i)
    Next
    'выгрузка на лист
    [z5].Resize(UBound(a), 1) = a

End Sub
[/vba]

А вот когда между 7 и 9 столбцом попробовал вставить еще и 8-й:[vba]
Код
a = ActiveSheet.UsedRange.Columns(8).Value
    For i = 5 To UBound(a)
        t = Trim(a(i, 1))
        If Len(t) Then col.Remove t
    Next
[/vba]
то сразу макрос стопориться в отладку и подсвечивает col.Remove t. Там что, лимит строк стоит? 8-я строчка из "убираем" тоже нужна

Автор - Leviven
Дата добавления - 21.07.2020 в 13:46
Hugo Дата: Вторник, 21.07.2020, 14:16 | Сообщение № 5
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3133
Репутация: 670 ±
Замечаний: 0% ±

2010, теперь уже с PQ
Я там выше оптимизировал немного код, но никакие лимиты не ставил и не убирал, у макроса нет лимитов!
А про ограничения я сказал - без дубликатов и дураков.
Вообще я думаю нужно менять кардинально саму систему:
для учета делаете простую плоскую таблицу -
фио|отделение|действие|дата+время
Так можно восстановить ситуацию вообще на любой момент времени, если нужно.
А сам отчёт по этим данным можно делать хоть в Экселе, а лучше в BI типа MSPowerBI/Qlik/Tableau


excel@nxt.ru
webmoney: R418926282008 Z422237915069


Сообщение отредактировал Hugo - Вторник, 21.07.2020, 14:21
 
Ответить
СообщениеЯ там выше оптимизировал немного код, но никакие лимиты не ставил и не убирал, у макроса нет лимитов!
А про ограничения я сказал - без дубликатов и дураков.
Вообще я думаю нужно менять кардинально саму систему:
для учета делаете простую плоскую таблицу -
фио|отделение|действие|дата+время
Так можно восстановить ситуацию вообще на любой момент времени, если нужно.
А сам отчёт по этим данным можно делать хоть в Экселе, а лучше в BI типа MSPowerBI/Qlik/Tableau

Автор - Hugo
Дата добавления - 21.07.2020 в 14:16
Leviven Дата: Вторник, 21.07.2020, 14:19 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 38
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Hugo, БОЛЬШОЕ ЧЕЛОВЕЧЕСКОЕ СПАСИБО!!! Работает!
 
Ответить
СообщениеHugo, БОЛЬШОЕ ЧЕЛОВЕЧЕСКОЕ СПАСИБО!!! Работает!

Автор - Leviven
Дата добавления - 21.07.2020 в 14:19
Leviven Дата: Вторник, 21.07.2020, 14:21 | Сообщение № 7
Группа: Пользователи
Ранг: Новичок
Сообщений: 38
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Hugo, С однофамильцами проблем не будет - в этих строках не только фамилии, но и имена с отчествами пациентов. Вероятность встречи двух Ивановых Иван Иванычей в одном списке стремится к нулю.
 
Ответить
СообщениеHugo, С однофамильцами проблем не будет - в этих строках не только фамилии, но и имена с отчествами пациентов. Вероятность встречи двух Ивановых Иван Иванычей в одном списке стремится к нулю.

Автор - Leviven
Дата добавления - 21.07.2020 в 14:21
Hugo Дата: Вторник, 21.07.2020, 14:27 | Сообщение № 8
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3133
Репутация: 670 ±
Замечаний: 0% ±

2010, теперь уже с PQ
Тогда они должны быть всюду написаны одинаково. А это трудно :(
Лучше каждому дать ID ну или там номер какой уже есть (у нас у всех есть персональные коды и таких проблем нет) и вести учёт по ним.
А ФИО в итоговый отчёт по этим номерам можно подтянуть из списка хоть впром, хоть макросом по словарю или той же коллекции.


excel@nxt.ru
webmoney: R418926282008 Z422237915069
 
Ответить
СообщениеТогда они должны быть всюду написаны одинаково. А это трудно :(
Лучше каждому дать ID ну или там номер какой уже есть (у нас у всех есть персональные коды и таких проблем нет) и вести учёт по ним.
А ФИО в итоговый отчёт по этим номерам можно подтянуть из списка хоть впром, хоть макросом по словарю или той же коллекции.

Автор - Hugo
Дата добавления - 21.07.2020 в 14:27
Leviven Дата: Вторник, 21.07.2020, 14:47 | Сообщение № 9
Группа: Пользователи
Ранг: Новичок
Сообщений: 38
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Hugo, Точно, по номеру истории болезни! Он уникален. Вы гений! Еще раз благодарю.
 
Ответить
СообщениеHugo, Точно, по номеру истории болезни! Он уникален. Вы гений! Еще раз благодарю.

Автор - Leviven
Дата добавления - 21.07.2020 в 14:47
Hugo Дата: Вторник, 21.07.2020, 16:25 | Сообщение № 10
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3133
Репутация: 670 ±
Замечаний: 0% ±

2010, теперь уже с PQ
На практике нужно бы ещё обрабатывать возможные ошибки ввода этих номеров - или сразу на лету подтягивать из справочника ФИО и если такого нет то сообщать, или при удалении из коллекции несуществующего там номера что-то делать (это и с ФИО может быть). Ошибки ввода точно будут.


excel@nxt.ru
webmoney: R418926282008 Z422237915069
 
Ответить
СообщениеНа практике нужно бы ещё обрабатывать возможные ошибки ввода этих номеров - или сразу на лету подтягивать из справочника ФИО и если такого нет то сообщать, или при удалении из коллекции несуществующего там номера что-то делать (это и с ФИО может быть). Ошибки ввода точно будут.

Автор - Hugo
Дата добавления - 21.07.2020 в 16:25
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос, сравнивающий списки в разных столбцах на совпадение (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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