Казанский, Спасибо! Я знаю, что существующее решение вполне нормальное, но всегда хочется обойтись одной формулой без усложнения существующих таблиц. =) Если не затруднит, то поясните в чем состоит сложность?
Доброго времени суток! Имеется Таблица 1., в которой представлены некие объемы, разбитые по категориям и подкатегориям. Имеется Таблица 2., в которой задано соответсвие сочетания категории+подкатегории и подменяемого значения.
Хотелось бы прописать формулу массива (G13), которая бы суммировала значения из массива объемов в Таблице 1. по одному из подменяемых значений (F13). При этом хотелось бы обойтись без создания отдельной строки.(как получилось сделать в H13 c дополнительно прописанной 1-ой строкой с подменяемым значением).
Подскажите, пжста, конструкцию, которой можно бы было этого добиться элегантной формулой массива без использования макроса. Очень бы хотелось научится подменять значения в массиве в самой формуле без использования опосредованных способов. Мои попытки и пример во вложении. Заранее признателен.
Sub Set_Manager_PivotItems()
Dim PT As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
Dim rngEmps As Range
Dim i As Long
Application.ScreenUpdating = False
Set PT = Sheets("pivot").PivotTables("PivotTable3")
Set pf = PT.PivotFields("ФИО")
' get teacher name
Set rngEmps = Range("Teacher")
PT.ManualUpdate = True
On Error Resume Next
For i = 1 To rngEmps.Count
Set pi = pf.PivotItems(rngEmps.Cells(i).Value)
If Not pi Is Nothing Then Exit For
Next i
If pi Is Nothing Then
MsgBox "Проверьте ФИО преподавателя на листе Информация"
Else
pi.Visible = True
For Each pi In pf.PivotItems
pi.Visible = Not IsError(Application.Match(pi.Name, rngEmps, 0))
Next pi
End If
PT.ManualUpdate = False
Application.ScreenUpdating = True
End Sub
Sanja, Если я правильно понял и общий код выглядит так:
Код
Sub Macro1()
On Error Resume Next
Sheets("pivot").PivotTables("PivotTable3").PivotFields("ФИО").CurrentPage = _
Sheets("Информация").Cells(34, 2).Value
If Err <> 0 Then
MsgBox "Проверьте ФИО преподавателя на листе Информация"
Sheets("pivot").PivotTables("PivotTable3").PivotFields("ФИО").ClearAllFilters
End If
End Sub
, то при вводе в ячейку B34 любого абстрактного значения, которого нет в сводной таблице, то это значение каким-то макаром добавляется в фильтр сводной таблицы, но при этом сообщение не выводится и фильтр не сбрасывается. Т.е. ошибка не отрабатывает.
Sanja, спасибо за внимание к теме. При вводе не абстрактного, а конкретно значения, которое присутствует в сводной таблице, вы получите ровно тот же результат (сообщение + сброс фильтров), а это не комильфо. Ограничить значения выпадающим списком можно, но список будет динамическим и находиться в другой книге, а хотелось бы автономности.
Спасибо за внимание к теме. При вводе не абстрактного, а конкретно значения, которое присутствует в сводной таблице, вы получите ровно тот же результат (сообщение + сброс фильтров), а это не комильфо. Ограничить значения выпадающим списком можно, но список будет динамическим и находиться в другой книге, а хотелось бы автономности.
Написал небольшой макрос, который на листе "pivot" выбирает в фильтре сводной таблицы значение из ячейки B34 листа "Информация". Проблема возникла, когда значения ячейки B34 листа "Информация" нет в списке доступных значений сводной таблицы и макрос вылетает в ошибку. Пробовал прописать, чтобы при появлении подобной ошибки пользователю выводилось уведомления + сбрасывались фильтры сводной таблицы (ниже код), но не приуспел в этом. Есть какая-то логическая ошибка, но не понимаю где. Заранее признателен за помощь.
Код
Sub Macro1()
On Error Resume Next
Sheets("pivot").PivotTables("PivotTable3").PivotFields("ФИО").CurrentPage = _
Sheets("Информация").Cells(34, 2).Value
If Error Then
MsgBox "Проверьте ФИО преподавателя на листе Информация"
Sheets("pivot").PivotTables("PivotTable3").PivotFields("ФИО").ClearAllFilters
End If
End Sub
Дабы не плодить отдельную тему, использую эту. Имеется строка с объединенными ячейками (merged cells). При копировании сроки и ее последующей вставке выше следующим кодом объединение ячеек пропадеет.
Вопрос: есть ли способ сделать код более лаконичным(в т.ч.) без команды Select и сохранив функционал (объединение ячеек остается)? Или единственный способ это затем отдельным куском кода объединять ячейки? Это вариант, если заранее известны все диапазоны с объединенными ячейками в строке, но если их много, то вычисления этих диапазонов не стоят труда и сделают код более громоздким.
Пример прилагаю. Оба варианта записаны в макросы КопированиеСтроки_wrong (неправильный вариант) и КопированиеСтроки_right (правильный вариант)
Обнаружил свою глупую ошибку в последовательности действий Вот работающий кусок кода, если кому интересно
Код
Dim k As Long
For k = 1 To Sheets("tech").Range("A" & Rows.Count).End(xlUp).Row 'цикл от 1 до ----последней непустой строки----- в столбце A листа Tech
On Error Resume Next '-----в случае ошибки переход к следующему оператору, т.е. без прерывания работы программы-----
Sheets(Sheets("tech").Range("A" & k).Value).Select '-----выбор листа с именем, равным содержимому указанной ячейки------ из столбца A листа Tech
Sheets("Макет").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = Sheets("Tech").Range("A" & k) 'переименновываем имя нового листа в значение ячейки за дату на которую создаем
ActiveSheet.Cells(2, 7).Value = "Лист " & (Workbooks(1).Sheets.Count - 3) 'Прописываем на листе порядковый номер
rw = 7 'номер первой строки для выгрузки
For i = 1 To UBound(a) 'проходим по строкам массива
If CDate(a(i, 4)) = CDate(ActiveSheet.Name) Then 'если дата из четвертой колонки массива совпадает с именем активного листа то
Cells(rw, 1) = a(i, 1) 'переносим на лист значения номера ПКО/РКО из массива
Cells(rw, 2) = a(i, 3) 'переносим на лист значения контрагента из массива
If a(i, 5) > 0 Then Cells(rw, 6) = a(i, 5) Else Cells(rw, 7) = a(i, 5) * (-1) 'переносим на лист суммы из массива, в зависимости от значения
Dim lFirstRow As Long, rFndRng As Range
Set rFndRng = ActiveSheet.UsedRange.Find("Итого за день", , xlFormulas, xlPart) 'ищем ячейку на активном листе, содержащую "Итого за день"
If rFndRng Is Nothing Then 'Если не находим - прерываем, выводим уведомление
MsgBox "Лист не содержит ИтогоЗаДень в листе", vbInformation, "Информация": Exit Sub
End If
lFirstRow = rFndRng.Row - 1 ' вычисляем строку, находящуюся выше ячейки с "Итого за день"
'Копируем найденную строку и вставляем выше
Rows(lFirstRow).Select
Selection.Copy
Selection.Insert Shift:=xlDown
rw = rw + 1 'увеличиваем счётчик строк
End If
Next
Next k
Тему можно закрывать. Однако буду признателен за советы в оптимизации кода для целей самообразования.
Добрый вечер. Существует рабочая задача генерации листов кассовой книги по шаблону на каждый день, когда в кассе производились операциии, из листа "Касса" (где приведены все операции за период) с переносом данных на лист дня и подведения там итогов за день. Путем записи действий макрорекордером, редактирования и подгонки чужих решений под свои нужды, самопросвещения был получен работающий макрос "КассовыйЛистДата", который выполняет указанную задачу, за исключеним следующего: В шаблонном листе "Макет" в ячейках F9,G9 идет подсчет значений за день SUM(F$7:F8). Чтобы диапазон подсчета динамически менялся для каждой конкретной даты, то в голову пришло вычислять первую пустую строку над итогами (в шаблоне - 8-я) и копировать ее на уровень выше (реализовано в макросе "КопированиеСтроки", работает активном листе, для целей тестирования выполняется на листе "Макет") для каждой кассовой операции, которая копируется на лист дня. Но при попытке совместить два макроса в один "КассовыйЛистДата_upd" происходит копирование пустых строк не числу перенесенных операций на каждый конкретных лист дня, а по числу строк в массиве.
Код
Dim k As Long
For k = 1 To Sheets("tech").Range("A" & Rows.Count).End(xlUp).Row 'цикл от 1 до ----последней непустой строки----- в столбце A листа Tech
On Error Resume Next '-----в случае ошибки переход к следующему оператору, т.е. без прерывания работы программы-----
Sheets(Sheets("tech").Range("A" & k).Value).Select '-----выбор листа с именем, равным содержимому указанной ячейки------ из столбца A листа Tech
Sheets("Макет").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = Sheets("Tech").Range("A" & k) 'переименновываем имя нового листа в значение ячейки за дату на которую создаем
ActiveSheet.Cells(2, 7).Value = "Лист " & (Workbooks(1).Sheets.Count - 3) 'Прописываем на листе порядковый номер
rw = 7 'номер первой строки для выгрузки
For i = 1 To UBound(a) 'проходим по строкам массива
Dim lFirstRow As Long, rFndRng As Range
Set rFndRng = ActiveSheet.UsedRange.Find("Итого за день", , xlFormulas, xlPart) 'ищем ячейку на активном листе, содержащую "Итого за день"
If rFndRng Is Nothing Then 'Если не находим - прерываем, выводим уведомление
MsgBox "Лист не содержит ИтогоЗаДень в листе", vbInformation, "Информация": Exit Sub
End If
lFirstRow = rFndRng.Row - 1 ' вычисляем строку, находящуюся выше ячейки с "Итого за день"
'Копируем найденную строку и вставляем выше
Rows(lFirstRow).Select
Selection.Copy
Selection.Insert Shift:=xlDown
If CDate(a(i, 4)) = CDate(ActiveSheet.Name) Then 'если дата из четвертой колонки массива совпадает с именем активного листа то
Cells(rw, 1) = a(i, 1) 'переносим на лист значения номера ПКО/РКО из массива
Cells(rw, 2) = a(i, 3) 'переносим на лист значения контрагента из массива
If a(i, 5) > 0 Then Cells(rw, 6) = a(i, 5) Else Cells(rw, 7) = a(i, 5) * (-1) 'переносим на лист суммы из массива, в зависимости от значения
rw = rw + 1 'увеличиваем счётчик строк
End If
Next
Next k
Пробовал разместить кусок кода за разных частях цикла, но лучшего результата не получил. Подскажите в чем ошибка и каким образом прописать копирование cтроки кажлый раз когда операция из массива добавляется на лист дня?
Файл приложен, MS Excel 2010, Искомый результат для 08.01.2016 приведен на соответствующем листе, маркированным желтым.
Один из способов реализации выпадающего списка, описанный в Приемах на сайте, является добавление элемента ActiveX "Поле со списком" (Способ 4 по ссылке ниже) http://www.planetaexcel.ru/techniques/1/40/ Данный способ является оптимальным с точки зрения описываемой ниже задачи, т.к, позволяет: 1) Осуществлять быстрый поиск элемента по первым буквам 2) При использовании этого способа, также возможно указывать в качестве ListFillRange многомерные диапазоны с последующим отображением в выпадающем списке
В статье "Выпадающий список с мультивыбором" описан макрос, позволяющий добавлять выбранные из выпадающего списка, построеннго через Data Validation, элементы один за другим, где они появляются снизу от изменяемой ячейки, автоматически составляясь в список по вертикали (Вариант 2. Вертикальный по ссылке ниже) http://www.planetaexcel.ru/techniques/1/181/
Идея состоит в том, чтобы объединить два приема в один. В приложенном файле существует лист "Contacts" с перечнем лиц. На листе "Взносы" необходимо добавлять выбранные из выпадающего списка (сделанного как ActiveX "Поле со списком" )элементы в диапазон B4:B n-ое один за другим автоматически составляясь в список по вертикали. Проблема возникает при попытке доработать код исходного макроса. Насколько могу прочитать его смысл: при изменений значения, заданного в области Range("C2:F2"), значение смешается вниз от области с помощью оператора Target.Offset(1, 0).
Код
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Range("C2:C5")) Is Nothing And Target.Cells.Count = 1 Then
Application.EnableEvents = False
If Len(Target.Offset(0, 1)) = 0 Then
Target.Offset(0, 1) = Target
Else
Target.End(xlToRight).Offset(0, 1) = Target
End If
Target.ClearContents
Application.EnableEvents = True
End If
End Sub
Пробовал минимальными усилиями изменить Range на Shapes.Range(Array("ComboBox1"), пробовал задать через ComboBox1_Change(), но не преуспел в этом. Не понимаю в том числе как прописать область,в которую я хочу вносить новые элементы. Буду признателен за совет. Спасибо.