Выбрать дату в календареВыбрать дату в календаре

Страницы: 1
Суммирование данных в диапазоне после подмены заголовков, заголовки служат критерием для суммирования
 
Казанский,
Спасибо! Я знаю, что существующее решение вполне нормальное, но всегда хочется обойтись одной формулой без усложнения существующих таблиц. =)
Если не затруднит, то поясните в чем состоит сложность?
Суммирование данных в диапазоне после подмены заголовков, заголовки служат критерием для суммирования
 
Up.
Буду признателен также за ответы "Это технически невозможнл" или "Яне смог/знаю как этт сделать"
Суммирование данных в диапазоне после подмены заголовков, заголовки служат критерием для суммирования
 
Пытливый, готово. Мои извинения. Изначально залил неверный файл с примером
Суммирование данных в диапазоне после подмены заголовков, заголовки служат критерием для суммирования
 
Доброго времени суток!
Имеется Таблица 1., в которой представлены некие объемы, разбитые по категориям и подкатегориям.
Имеется Таблица 2., в которой задано соответсвие сочетания категории+подкатегории и подменяемого значения.

Хотелось бы прописать формулу массива (G13), которая бы суммировала значения из массива объемов в Таблице 1. по одному из подменяемых значений (F13). При этом хотелось бы обойтись без создания отдельной строки.(как получилось сделать в H13 c дополнительно прописанной 1-ой строкой с подменяемым значением).

Подскажите, пжста, конструкцию, которой можно бы было этого добиться элегантной формулой массива без использования макроса.
Очень бы хотелось научится подменять значения в массиве в самой формуле без использования опосредованных способов.
Мои попытки и пример во вложении.
Заранее признателен.
Изменено: Radament - 15.01.2018 12:43:52
Прерывание макроса при ошибке ввода в Pivot
 
Equio,
Спасибо. Вот что вышло
Код
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
Изменено: Radament - 12.10.2017 18:20:12
Прерывание макроса при ошибке ввода в Pivot
 
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 любого абстрактного значения, которого нет в сводной таблице, то это значение каким-то макаром добавляется в фильтр сводной таблицы, но при этом сообщение не выводится и фильтр не сбрасывается. Т.е. ошибка не отрабатывает.
Прерывание макроса при ошибке ввода в Pivot
 
Sanja, спасибо за внимание к теме. При вводе не абстрактного, а конкретно значения, которое присутствует в сводной таблице, вы получите ровно тот же результат (сообщение + сброс фильтров), а это не комильфо.
Ограничить значения выпадающим списком можно, но список будет динамическим и находиться в другой книге, а хотелось бы автономности.
Прерывание макроса при ошибке ввода в Pivot
 
Спасибо за внимание к теме. При вводе не абстрактного, а конкретно значения, которое присутствует в сводной таблице, вы получите ровно тот же результат (сообщение + сброс фильтров), а это не комильфо.
Ограничить значения выпадающим списком можно, но список будет динамическим и находиться в другой книге, а хотелось бы автономности.
Прерывание макроса при ошибке ввода в Pivot
 
Написал небольшой макрос, который на листе "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
Пропадает объединение ячеек после Copy-Paste
 
Дабы не плодить отдельную тему, использую эту.
Имеется строка с объединенными ячейками (merged cells). При копировании сроки и ее последующей вставке выше следующим кодом объединение ячеек пропадеет.
Код
    Rows(lFirstRow).Offset(1).Resize(1).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Если попытаться скопировать строку и вставить ее выше вручную, то объединение ячеек остается, а макрорекордер выдает следующих код:
Код
    Rows(lFirstRow).Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
    Selection.Deselect
Вопрос: есть ли способ сделать код более лаконичным(в т.ч.) без команды Select и сохранив функционал (объединение ячеек остается)?
Или единственный способ это затем отдельным куском кода объединять ячейки? Это вариант, если заранее известны все диапазоны с объединенными ячейками в строке, но если их много, то вычисления этих диапазонов не стоят труда и сделают код более громоздким.

Пример прилагаю. Оба варианта записаны в макросы КопированиеСтроки_wrong (неправильный вариант) и КопированиеСтроки_right (правильный вариант)
Изменено: Radament - 30.09.2016 16:30:07
Вставка n - cтрок при обработке n-позиций массива для листа
 
Обнаружил свою глупую ошибку в последовательности действий
Вот работающий кусок кода, если кому интересно
Код
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
Тему можно закрывать. Однако буду признателен за советы в оптимизации кода для целей самообразования.
Изменено: Radament - 28.09.2016 19:46:00
Вставка n - cтрок при обработке n-позиций массива для листа
 
Добрый вечер.
Существует рабочая задача генерации листов кассовой книги по шаблону на каждый день, когда в кассе производились операциии, из листа "Касса" (где приведены все операции за период) с переносом данных на лист дня и подведения там итогов за день.
Путем записи действий макрорекордером, редактирования и подгонки чужих решений под свои нужды, самопросвещения был получен работающий макрос "КассовыйЛистДата", который выполняет указанную задачу, за исключеним следующего:
В шаблонном листе "Макет" в ячейках 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 приведен на соответствующем листе, маркированным желтым.
Изменено: Radament - 28.09.2016 20:08:42
Выпадающий список ActiveX + вертикальное накопление
 
up
Выпадающий список ActiveX + вертикальное накопление
 
Один из способов реализации выпадающего списка, описанный в Приемах на сайте, является добавление элемента 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(), но не преуспел в этом. Не понимаю в том числе как прописать область,в которую я хочу вносить новые элементы.
Буду признателен за совет.
Спасибо.
Изменено: Radament - 24.07.2015 16:40:45
Страницы: 1
Наверх