Доброго времени суток. Имеются столбцы с данными: A B C и ячейки с условиями D3, E1, F1, G1, H1, I1 Необходимо в ячейках E3, F3, G3, H3, I3 получить ответ исходя из условий. "пример для ячейки E3": ищет в столбце B все строки соответствующие дате из E1 (20.01.2021), проверяет, что у найденных строк в столбце С стоит цифра соответствующая ячейке D3, вписывает все подходящие значения из столбца А в ячейку E3, при этом если у номеров в столбце А (№) имеется последовательность (1, 2, 3, 12) то пишет значение диапазоном 1-3, 12 (в ячейке G3 нет диапазона, т.ч. пишет 6, 13, 7)
На одном из форумов, с похожей тематикой, предложили следующий макрос. К сожалению, эксель ругается на строку и макрос с ней не работает.
[/vba] Если удалить строку - работает, но данные не выводятся диапазоном (1-3, 12, а пишется, 1-2-3, 12) Не могу понять, в чем проблема. Файл прикрепил.
[vba]
Код
Sub mrshkei() Dim arr, arr2, arr3, i As Long, n As Long, lr As Long, lcol As Long, tt As String, col As New Collection lr = Cells(Rows.Count, 1).End(xlUp).Row lcol = Cells(1, Columns.Count).End(xlToLeft).Column Range("A2:C" & lr).Select ActiveWorkbook.Worksheets("Лист2").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Лист2").Sort.SortFields.Add2 Key:=Range("A3:A" & lr) _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Лист2").Sort .SetRange Range("A2:C" & lr) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With arr = Range("A3:C" & lr) arr2 = Range(Cells(1, 5), Cells(1, lcol)) ReDim arr3(1 To 1, 1 To UBound(arr2, 2) - LBound(arr2) + 1): K = 1 For i = LBound(arr2) To UBound(arr2, 2) - LBound(arr2) + 1 tt = "" Set col = Nothing For n = LBound(arr) To UBound(arr) If arr2(1, i) = arr(n, 2) And arr(n, 3) = [D3] Then On Error Resume Next col.Add arr(n, 1), CStr(arr(n, 1)) End If Next n For n = col.Count To 1 Step -1 If tt = "" Then tt = col(n) Else If col(n + 1) = col(n) + 1 Then tt = col(n) & " - " & tt Else tt = col(n) & ", " & tt End If End If Next n arr3(1, K) = tt: K = K + 1 Next i Range("E3").Resize(1, UBound(arr3, 2) - LBound(arr3) + 1).NumberFormat = "@" Range("E3").Resize(1, UBound(arr3, 2) - LBound(arr3) + 1) = arr3 End Sub
[/vba]
Доброго времени суток. Имеются столбцы с данными: A B C и ячейки с условиями D3, E1, F1, G1, H1, I1 Необходимо в ячейках E3, F3, G3, H3, I3 получить ответ исходя из условий. "пример для ячейки E3": ищет в столбце B все строки соответствующие дате из E1 (20.01.2021), проверяет, что у найденных строк в столбце С стоит цифра соответствующая ячейке D3, вписывает все подходящие значения из столбца А в ячейку E3, при этом если у номеров в столбце А (№) имеется последовательность (1, 2, 3, 12) то пишет значение диапазоном 1-3, 12 (в ячейке G3 нет диапазона, т.ч. пишет 6, 13, 7)
На одном из форумов, с похожей тематикой, предложили следующий макрос. К сожалению, эксель ругается на строку и макрос с ней не работает.
[/vba] Если удалить строку - работает, но данные не выводятся диапазоном (1-3, 12, а пишется, 1-2-3, 12) Не могу понять, в чем проблема. Файл прикрепил.
[vba]
Код
Sub mrshkei() Dim arr, arr2, arr3, i As Long, n As Long, lr As Long, lcol As Long, tt As String, col As New Collection lr = Cells(Rows.Count, 1).End(xlUp).Row lcol = Cells(1, Columns.Count).End(xlToLeft).Column Range("A2:C" & lr).Select ActiveWorkbook.Worksheets("Лист2").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Лист2").Sort.SortFields.Add2 Key:=Range("A3:A" & lr) _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Лист2").Sort .SetRange Range("A2:C" & lr) .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With arr = Range("A3:C" & lr) arr2 = Range(Cells(1, 5), Cells(1, lcol)) ReDim arr3(1 To 1, 1 To UBound(arr2, 2) - LBound(arr2) + 1): K = 1 For i = LBound(arr2) To UBound(arr2, 2) - LBound(arr2) + 1 tt = "" Set col = Nothing For n = LBound(arr) To UBound(arr) If arr2(1, i) = arr(n, 2) And arr(n, 3) = [D3] Then On Error Resume Next col.Add arr(n, 1), CStr(arr(n, 1)) End If Next n For n = col.Count To 1 Step -1 If tt = "" Then tt = col(n) Else If col(n + 1) = col(n) + 1 Then tt = col(n) & " - " & tt Else tt = col(n) & ", " & tt End If End If Next n arr3(1, K) = tt: K = K + 1 Next i Range("E3").Resize(1, UBound(arr3, 2) - LBound(arr3) + 1).NumberFormat = "@" Range("E3").Resize(1, UBound(arr3, 2) - LBound(arr3) + 1) = arr3 End Sub
Добрый вечер! Большое спасибо! Макрос выводит именно то, что требовалось (диапазон значений, там, где это возможно). В ходе изучения кода и результатов выяснил, что фильтрация диапазона данных по столбцу "А" мне не нужна, т.к. мешает обрабатывать итоги. Убрал ее.
Не знаю, противоречит мой дополнительный вопрос правилам форума или его можно считать продолжением темы, но все же спрошу: Что необходимо изменить и на что (как это правильно должно выглядеть), если исходные данные (столбцы A, B, C) будут находиться не на этом листе, а на другом или в другой книге? Если я правильно понимаю, то сейчас их местоположение задает вот эта строка: arr = Range("A3:C" & lr)
Добрый вечер! Большое спасибо! Макрос выводит именно то, что требовалось (диапазон значений, там, где это возможно). В ходе изучения кода и результатов выяснил, что фильтрация диапазона данных по столбцу "А" мне не нужна, т.к. мешает обрабатывать итоги. Убрал ее.
Не знаю, противоречит мой дополнительный вопрос правилам форума или его можно считать продолжением темы, но все же спрошу: Что необходимо изменить и на что (как это правильно должно выглядеть), если исходные данные (столбцы A, B, C) будут находиться не на этом листе, а на другом или в другой книге? Если я правильно понимаю, то сейчас их местоположение задает вот эта строка: arr = Range("A3:C" & lr)SSre
Правильно понимаете Если диапазон на другом листе, то надо добавить обращение к листу, например, Sheets("Лист1").Range("A3:C" & lr), а если в другой книге, то ещё и обращение к книге
Правильно понимаете Если диапазон на другом листе, то надо добавить обращение к листу, например, Sheets("Лист1").Range("A3:C" & lr), а если в другой книге, то ещё и обращение к книгеPelena
"Черт возьми, Холмс! Но как??!!" Ю-money 41001765434816
Здравствуйте! Начал корректировать Ваш код и, похоже, поломал его.. могу я попросить еще об одной услуге/консультации? Я прикрепил 2 файла (11 и 22), почему при запуске макроса на листе 11 показывает только 24 числа 1-13? Во-первых с 1 по 13 это 23 число, а не 24 Во-вторых номера 24 числа вообще не показываются
Такое впечатление, что формула не определяет значения ниже по строчкам какого-то определенного момента. Я хотел проверить, что можно в файл "22" поставить на 1000+ строчку дату и значения, нажать макрос и на файле "11" получить корректный итог.. - не получил, осилить сам причину не смог [vba]
Код
Sub WWWWW() Dim arr, arr2, arr3, arr4, i As Long, n As Long, lr As Long, lcol As Long, tt As String, col As New Collection, fl As Boolean Set wb = ThisWorkbook: Set wb2 = Workbooks("22.xlsx") lr = Cells(Rows.Count, 1).End(xlUp).Row lcol = Cells(14, Columns.Count).End(xlToLeft).Column arr = wb2.Sheets(2).Range("A3:AK" & lr) arr2 = wb.Sheets(1).Range(Cells(14, 4), Cells(14, lcol)) arr3 = wb2.Sheets(2).Range("A3:AK" & lr) ReDim arr4(1 To 1, 1 To UBound(arr2, 2) - LBound(arr2) + 1): K = 1 For i = LBound(arr2) To UBound(arr2, 2) - LBound(arr2) + 1 tt = "" Set col = Nothing For n = LBound(arr) To UBound(arr) If arr2(1, i) = arr(n, 16) And arr(n, 33) = [C17] And arr3(n, 10) = [A15] Then On Error Resume Next col.Add arr(n, 1), CStr(arr(n, 1)) End If Next n For n = 1 To col.Count tt = tt & ", " & col(n) Do While col(n) = col(n + 1) - 1 And n < col.Count fl = True: n = n + 1 If n >= col.Count Then Exit Do Loop If fl Then tt = tt & "-" & col(n): fl = False Next n arr4(1, K) = Mid(tt, 3): K = K + 1 Next i Range("E18").Resize(1, UBound(arr4, 2) - LBound(arr4) + 1).NumberFormat = "@" Range("E18").Resize(1, UBound(arr4, 2) - LBound(arr4) + 1) = arr4 End Sub
Здравствуйте! Начал корректировать Ваш код и, похоже, поломал его.. могу я попросить еще об одной услуге/консультации? Я прикрепил 2 файла (11 и 22), почему при запуске макроса на листе 11 показывает только 24 числа 1-13? Во-первых с 1 по 13 это 23 число, а не 24 Во-вторых номера 24 числа вообще не показываются
Такое впечатление, что формула не определяет значения ниже по строчкам какого-то определенного момента. Я хотел проверить, что можно в файл "22" поставить на 1000+ строчку дату и значения, нажать макрос и на файле "11" получить корректный итог.. - не получил, осилить сам причину не смог [vba]
Код
Sub WWWWW() Dim arr, arr2, arr3, arr4, i As Long, n As Long, lr As Long, lcol As Long, tt As String, col As New Collection, fl As Boolean Set wb = ThisWorkbook: Set wb2 = Workbooks("22.xlsx") lr = Cells(Rows.Count, 1).End(xlUp).Row lcol = Cells(14, Columns.Count).End(xlToLeft).Column arr = wb2.Sheets(2).Range("A3:AK" & lr) arr2 = wb.Sheets(1).Range(Cells(14, 4), Cells(14, lcol)) arr3 = wb2.Sheets(2).Range("A3:AK" & lr) ReDim arr4(1 To 1, 1 To UBound(arr2, 2) - LBound(arr2) + 1): K = 1 For i = LBound(arr2) To UBound(arr2, 2) - LBound(arr2) + 1 tt = "" Set col = Nothing For n = LBound(arr) To UBound(arr) If arr2(1, i) = arr(n, 16) And arr(n, 33) = [C17] And arr3(n, 10) = [A15] Then On Error Resume Next col.Add arr(n, 1), CStr(arr(n, 1)) End If Next n For n = 1 To col.Count tt = tt & ", " & col(n) Do While col(n) = col(n + 1) - 1 And n < col.Count fl = True: n = n + 1 If n >= col.Count Then Exit Do Loop If fl Then tt = tt & "-" & col(n): fl = False Next n arr4(1, K) = Mid(tt, 3): K = K + 1 Next i Range("E18").Resize(1, UBound(arr4, 2) - LBound(arr4) + 1).NumberFormat = "@" Range("E18").Resize(1, UBound(arr4, 2) - LBound(arr4) + 1) = arr4 End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
