Добрый день, форумчане! Макросы в Модуле2 производят сравнение списка из столбца "B" поочередно со столбцами "I", "J" и "K", выводя поочередно списки в дополнительные столбцы: "L", "M" и "N", убирая одинаковые фамилии. Затем результат заносится в итоговый столбец "Z" (Состоит больных). В принципе, все работает, макросы поочередно запускают друг друга, но...как-то громоздко получается. Идет сравнение только двух списков в одном макросе. По-другому у меня не получилось. В связи с этим вопрос: можно ли обойтись без дополнительных столбцов - "L", "M" и "N" и кучи макросов и выполнить напрямую сравнение списка из столбца "B" со столбцами "I", "J" и "K" на совпадения и занести уникальный результат сразу в итоговый столбец "Z" одним макросом? Пример прилагаю.
Добрый день, форумчане! Макросы в Модуле2 производят сравнение списка из столбца "B" поочередно со столбцами "I", "J" и "K", выводя поочередно списки в дополнительные столбцы: "L", "M" и "N", убирая одинаковые фамилии. Затем результат заносится в итоговый столбец "Z" (Состоит больных). В принципе, все работает, макросы поочередно запускают друг друга, но...как-то громоздко получается. Идет сравнение только двух списков в одном макросе. По-другому у меня не получилось. В связи с этим вопрос: можно ли обойтись без дополнительных столбцов - "L", "M" и "N" и кучи макросов и выполнить напрямую сравнение списка из столбца "B" со столбцами "I", "J" и "K" на совпадения и занести уникальный результат сразу в итоговый столбец "Z" одним макросом? Пример прилагаю.Leviven
Добрый день. Там ещё и первый модуль своё добавляет. Делайте на коллекции или словаре - будет проще и быстрее. Сперва собираете в объект всех поступивших, затем удаляете выбывших, остаток выгружаете. Но вот как Вы будете решать проблему Ивановых - мне по примеру непонятно, поэтому я пока не участвую
Добрый день. Там ещё и первый модуль своё добавляет. Делайте на коллекции или словаре - будет проще и быстрее. Сперва собираете в объект всех поступивших, затем удаляете выбывших, остаток выгружаете. Но вот как Вы будете решать проблему Ивановых - мне по примеру непонятно, поэтому я пока не участвую Hugo
Хотя вот, сделал. Работает пока нет однофамильцев!
[vba]
Код
Option Explicit
Sub tt() Dim col As New Collection Dim a, el, i&, t$
'добавляем For Each el In Array(2, 3, 22, 23, 24, 25) a = ActiveSheet.UsedRange.Columns(el).Value For i = 5 To UBound(a) t = Trim(a(i, 1)) If t <> "0" Then If Len(t) Then col.Add t, t End If Next Next
'убираем For Each el In Array(9, 10, 11) a = ActiveSheet.UsedRange.Columns(el).Value For i = 5 To UBound(a) t = Trim(a(i, 1)) If Len(t) Then col.Remove t Next 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]
Тут нет защиты не только от повторов, но и от дураков. Т.е. когда Иванов не состоял, не поступал, но вдруг выбывает...
Хотя вот, сделал. Работает пока нет однофамильцев!
[vba]
Код
Option Explicit
Sub tt() Dim col As New Collection Dim a, el, i&, t$
'добавляем For Each el In Array(2, 3, 22, 23, 24, 25) a = ActiveSheet.UsedRange.Columns(el).Value For i = 5 To UBound(a) t = Trim(a(i, 1)) If t <> "0" Then If Len(t) Then col.Add t, t End If Next Next
'убираем For Each el In Array(9, 10, 11) a = ActiveSheet.UsedRange.Columns(el).Value For i = 5 To UBound(a) t = Trim(a(i, 1)) If Len(t) Then col.Remove t Next 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]
Тут нет защиты не только от повторов, но и от дураков. Т.е. когда Иванов не состоял, не поступал, но вдруг выбывает...Hugo
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
Я там выше оптимизировал немного код, но никакие лимиты не ставил и не убирал, у макроса нет лимитов! А про ограничения я сказал - без дубликатов и дураков. Вообще я думаю нужно менять кардинально саму систему: для учета делаете простую плоскую таблицу - фио|отделение|действие|дата+время Так можно восстановить ситуацию вообще на любой момент времени, если нужно. А сам отчёт по этим данным можно делать хоть в Экселе, а лучше в BI типа MSPowerBI/Qlik/Tableau
Я там выше оптимизировал немного код, но никакие лимиты не ставил и не убирал, у макроса нет лимитов! А про ограничения я сказал - без дубликатов и дураков. Вообще я думаю нужно менять кардинально саму систему: для учета делаете простую плоскую таблицу - фио|отделение|действие|дата+время Так можно восстановить ситуацию вообще на любой момент времени, если нужно. А сам отчёт по этим данным можно делать хоть в Экселе, а лучше в BI типа MSPowerBI/Qlik/TableauHugo
Hugo, С однофамильцами проблем не будет - в этих строках не только фамилии, но и имена с отчествами пациентов. Вероятность встречи двух Ивановых Иван Иванычей в одном списке стремится к нулю.
Hugo, С однофамильцами проблем не будет - в этих строках не только фамилии, но и имена с отчествами пациентов. Вероятность встречи двух Ивановых Иван Иванычей в одном списке стремится к нулю.Leviven
Тогда они должны быть всюду написаны одинаково. А это трудно Лучше каждому дать ID ну или там номер какой уже есть (у нас у всех есть персональные коды и таких проблем нет) и вести учёт по ним. А ФИО в итоговый отчёт по этим номерам можно подтянуть из списка хоть впром, хоть макросом по словарю или той же коллекции.
Тогда они должны быть всюду написаны одинаково. А это трудно Лучше каждому дать ID ну или там номер какой уже есть (у нас у всех есть персональные коды и таких проблем нет) и вести учёт по ним. А ФИО в итоговый отчёт по этим номерам можно подтянуть из списка хоть впром, хоть макросом по словарю или той же коллекции.Hugo
На практике нужно бы ещё обрабатывать возможные ошибки ввода этих номеров - или сразу на лету подтягивать из справочника ФИО и если такого нет то сообщать, или при удалении из коллекции несуществующего там номера что-то делать (это и с ФИО может быть). Ошибки ввода точно будут.
На практике нужно бы ещё обрабатывать возможные ошибки ввода этих номеров - или сразу на лету подтягивать из справочника ФИО и если такого нет то сообщать, или при удалении из коллекции несуществующего там номера что-то делать (это и с ФИО может быть). Ошибки ввода точно будут.Hugo
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
