Фильтрация во всех листах по заданному значению - Мир MS Excel

Регистрация

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

= Мир MS Excel/Фильтрация во всех листах по заданному значению - Мир MS Excel

Старая форма входа

Страница 1 из 2 1 2 »
Модератор форума: китин, _Boroda_

Фильтрация во всех листах по заданному значению (Макросы/Sub)

Фильтрация во всех листах по заданному значению

Дата: Суббота, 11.07.2020, 13:35 | Сообщение № 1

Группа: Пользователи

Ранг: Новичок

Сообщений: 34

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Добрый день!

Столкнулся с интересной задачей, есть Olap-куб на основании которого формируется сводная таблица, на нескольких листах разные сформированные таблицы в которых отображена требуемая информация, есть лист "Свод" в котором формулами эта информация собирается в нужную сжатую конечную таблицу.

Возник вопрос, как сделать фильтрацию на всех листах в схожих сводных таблицах по определённым значениям внесённым в ячейки на странице свод, что бы вбив несколько кодов товара дату и заказчика в ячейках G5:I8, во всех сводных фильтрация автоматически настроила сводные таблицы.

Пробовал сделать записью макроса но макрос не работал.

Поставил код на обновление сводных таблиц, работает, указываю ниже, может кому пригодится.
[vba]

Код

Sub ОбновлениеСводной()
'Шаг 1: Объявляем переменные
Dim ws As Worksheet
Dim pt As PivotTable
'Шаг 2: Запускаем цикл через каждый лист книги
For Each ws In ThisWorkbook.Worksheets
'Шаг 3: Запускаем цикл через все сводные таблицы
For Each pt In ws.PivotTables
pt.RefreshTable
Next pt
Next ws
End Sub

[/vba]

К сообщению приложен файл: 9026366.xls (126.0 Kb)

Сообщение отредактировал Bodrichkom - Суббота, 11.07.2020, 13:36

Ответить

Дата: Суббота, 11.07.2020, 14:17 | Сообщение № 2

Группа: Админы

Ранг: Местный житель

Сообщений: 19404

Репутация: 4555 ±

Замечаний: ±

Excel 365 & Mac Excel

Использование срезов, подключенных ко всем сводным не вариант?

К сообщению приложен файл: 9026366.xlsb (44.3 Kb)

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816

Ответить

Дата: Суббота, 11.07.2020, 14:27 | Сообщение № 3

Группа: Пользователи

Ранг: Новичок

Сообщений: 34

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Pelena, Пробовал ими, но получается не удобно, когда слишком большой ассортимент, хотелось бы именно с привязкой к информации в ячейках G5:I8

Ответить

Дата: Суббота, 11.07.2020, 14:54 | Сообщение № 4

Группа: Админы

Ранг: Местный житель

Сообщений: 19404

Репутация: 4555 ±

Замечаний: ±

Excel 365 & Mac Excel

Так вопрос макросом решён?

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816

Ответить

Дата: Суббота, 11.07.2020, 15:41 | Сообщение № 5

Группа: Пользователи

Ранг: Новичок

Сообщений: 34

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Pelena, нет, макрос который выложил, только обновляет все сводные, а тот что находил в интернете, либо не подходил, либо не работал, а сам я ума не приложу как макросом это воспроизвести, вот и решил совета попросить тут на форуме, вдруг кто уже делал такую задачу или знает как это сделать и направил бы ход мыслей в нужную сторону.

Ответить

Дата: Суббота, 11.07.2020, 23:34 | Сообщение № 6

Группа: Админы

Ранг: Местный житель

Сообщений: 19404

Репутация: 4555 ±

Замечаний: ±

Excel 365 & Mac Excel

Посмотрите такой вариант

К сообщению приложен файл: 5836715.xlsb (46.6 Kb)

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816

Ответить

Дата: Воскресенье, 12.07.2020, 09:32 | Сообщение № 7

Группа: Пользователи

Ранг: Новичок

Сообщений: 34

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Pelena, А вот этот вариант, именно то что искал, протестировал на разные возможные ошибки, работает превосходно, Вам ОГРООООМНОЕ Спасибо!!!!)

Ответить

Дата: Понедельник, 13.07.2020, 11:23 | Сообщение № 8

Группа: Пользователи

Ранг: Новичок

Сообщений: 34

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Pelena, Попробовал сегодня перенести код на Excel файл с Olap-кубом, выдаёт ошибку вот тут, [vba]

Код

With pt.PivotFields(arrField(1, f))

[/vba], может ошибка выходит из-за того, что в группах есть подгруппа "All"?

К сообщению приложен файл: 6906384.png (79.4 Kb)

Сообщение отредактировал Bodrichkom - Понедельник, 13.07.2020, 12:37

Ответить

Дата: Понедельник, 13.07.2020, 12:28 | Сообщение № 9

Группа: Пользователи

Ранг: Новичок

Сообщений: 34

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Pelena, Прикладываю скрин

К сообщению приложен файл: 8765464.png (35.7 Kb)

Ответить

Дата: Понедельник, 13.07.2020, 14:30 | Сообщение № 10

Группа: Админы

Ранг: Местный житель

Сообщений: 19404

Репутация: 4555 ±

Замечаний: ±

Excel 365 & Mac Excel

Судя по первому скрину, возможно не совпадают названия столбцов на листе Свод в табличке с критериями с названиями столбцов таблицы-источника.
С датами тоже возможна проблема из-за разного формата.
По поводу OLAP-куба ничего не могу сказать, есть ли там отличия от обычных сводных

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816

Ответить

Дата: Понедельник, 13.07.2020, 14:42 | Сообщение № 11

Группа: Пользователи

Ранг: Новичок

Сообщений: 34

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Pelena, Вложил скрин, названия копировал прям из свода, они идентичные, тоже на это сначала подумал, по поводу даты, попробовал без столбца даты, всё ровно та же ошибка, сижу вот голову ломаю, в чём же дело)

К сообщению приложен файл: 3628686.png (50.3 Kb)

Ответить

Дата: Понедельник, 13.07.2020, 16:59 | Сообщение № 12

Группа: Пользователи

Ранг: Новичок

Сообщений: 34

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Мне тут подсказали, что запись VBA у куба немного иная чем со сводными, выложу код, если кто знает, как его оформить, что бы заработал на Olap-кубах, прошу поправить или направить на путь истинный)
[vba]

Код

Sub ОбновлениеСводной()
'Шаг 1: Объявляем переменные
    Dim ws As Worksheet
    Dim pt As PivotTable, crit, i&, f&, it As PivotItem, arrField
    Dim odic As Object
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    arrField = Лист2.Range("X4:Y4").Value
    crit = Лист2.Range("X5:Y14").Value
    'Шаг 2: Запускаем цикл через каждый лист книги
    For Each ws In ThisWorkbook.Worksheets
        'Шаг 3: Запускаем цикл через все сводные таблицы
        For Each pt In ws.PivotTables
            For f = 1 To UBound(arrField, 2)
                Set odic = CreateObject("Scripting.Dictionary")
                For i = 1 To UBound(crit)
                    If crit(i, f) <> "" Then odic(FDynVal(crit(i, f))) = FDynVal(crit(i, f))
                Next i
                With pt.PivotFields(arrField(1, f))
                    .ClearAllFilters
                    If odic.Count > 0 Then
                        For Each it In .PivotItems
                            If odic.Exists(it.Value) Then .PivotItems(it.Value).Visible = True Else .PivotItems(it.Value).Visible = False
                        Next it
                    End If
                End With
            Next f
        Next pt
    Next ws
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub
Public Function FDynVal(FrmContrVal)
  If Len(FrmContrVal & "") = 0 Then
    FDynVal = ""
  Else
    Select Case VarType(FrmContrVal)
      Case 5
        FDynVal = CStr(FrmContrVal)
      Case 8
        FDynVal = FrmContrVal
      Case 7
        FDynVal = Format(FrmContrVal, "m\/d\/yyyy")
    End Select
  End If
End Function

[/vba]

Мне тут подсказали, что запись VBA у куба немного иная чем со сводными, выложу код, если кто знает, как его оформить, что бы заработал на Olap-кубах, прошу поправить или направить на путь истинный)
[vba]

Код

Sub ОбновлениеСводной()
'Шаг 1: Объявляем переменные
    Dim ws As Worksheet
    Dim pt As PivotTable, crit, i&, f&, it As PivotItem, arrField
    Dim odic As Object
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    arrField = Лист2.Range("X4:Y4").Value
    crit = Лист2.Range("X5:Y14").Value
    'Шаг 2: Запускаем цикл через каждый лист книги
    For Each ws In ThisWorkbook.Worksheets
        'Шаг 3: Запускаем цикл через все сводные таблицы
        For Each pt In ws.PivotTables
            For f = 1 To UBound(arrField, 2)
                Set odic = CreateObject("Scripting.Dictionary")
                For i = 1 To UBound(crit)
                    If crit(i, f) <> "" Then odic(FDynVal(crit(i, f))) = FDynVal(crit(i, f))
                Next i
                With pt.PivotFields(arrField(1, f))
                    .ClearAllFilters
                    If odic.Count > 0 Then
                        For Each it In .PivotItems
                            If odic.Exists(it.Value) Then .PivotItems(it.Value).Visible = True Else .PivotItems(it.Value).Visible = False
                        Next it
                    End If
                End With
            Next f
        Next pt
    Next ws
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub
Public Function FDynVal(FrmContrVal)
  If Len(FrmContrVal & "") = 0 Then
    FDynVal = ""
  Else
    Select Case VarType(FrmContrVal)
      Case 5
        FDynVal = CStr(FrmContrVal)
      Case 8
        FDynVal = FrmContrVal
      Case 7
        FDynVal = Format(FrmContrVal, "m\/d\/yyyy")
    End Select
  End If
End Function

[/vba]Bodrichkom

Ответить

СообщениеМне тут подсказали, что запись VBA у куба немного иная чем со сводными, выложу код, если кто знает, как его оформить, что бы заработал на Olap-кубах, прошу поправить или направить на путь истинный)
[vba]

Код

Sub ОбновлениеСводной()
'Шаг 1: Объявляем переменные
    Dim ws As Worksheet
    Dim pt As PivotTable, crit, i&, f&, it As PivotItem, arrField
    Dim odic As Object
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    arrField = Лист2.Range("X4:Y4").Value
    crit = Лист2.Range("X5:Y14").Value
    'Шаг 2: Запускаем цикл через каждый лист книги
    For Each ws In ThisWorkbook.Worksheets
        'Шаг 3: Запускаем цикл через все сводные таблицы
        For Each pt In ws.PivotTables
            For f = 1 To UBound(arrField, 2)
                Set odic = CreateObject("Scripting.Dictionary")
                For i = 1 To UBound(crit)
                    If crit(i, f) <> "" Then odic(FDynVal(crit(i, f))) = FDynVal(crit(i, f))
                Next i
                With pt.PivotFields(arrField(1, f))
                    .ClearAllFilters
                    If odic.Count > 0 Then
                        For Each it In .PivotItems
                            If odic.Exists(it.Value) Then .PivotItems(it.Value).Visible = True Else .PivotItems(it.Value).Visible = False
                        Next it
                    End If
                End With
            Next f
        Next pt
    Next ws
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub
Public Function FDynVal(FrmContrVal)
  If Len(FrmContrVal & "") = 0 Then
    FDynVal = ""
  Else
    Select Case VarType(FrmContrVal)
      Case 5
        FDynVal = CStr(FrmContrVal)
      Case 8
        FDynVal = FrmContrVal
      Case 7
        FDynVal = Format(FrmContrVal, "m\/d\/yyyy")
    End Select
  End If
End Function

[/vba]

Автор - Bodrichkom
Дата добавления - 13.07.2020 в 16:59

Дата: Понедельник, 13.07.2020, 17:32 | Сообщение № 13

Группа: Админы

Ранг: Местный житель

Сообщений: 19404

Репутация: 4555 ±

Замечаний: ±

Excel 365 & Mac Excel

В случае OLAP-кубов синтаксис другой и есть такое свойство VisibleItemsList, в которое, судя по справке, можно сразу массив критериев подгружать.
Посмотрите пример здесь
Видимо, вместо [vba]

Код

PivotFields(arrField(1, f))

[/vba]должно быть что-то вроде
[vba]

Код

PivotFields("[имя таблицы].[имя группы].[" & arrField(1, f) & "]")

[/vba]

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816

Ответить

Дата: Понедельник, 13.07.2020, 18:09 | Сообщение № 14

Группа: Пользователи

Ранг: Новичок

Сообщений: 34

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Pelena, Изменил [vba]

Код

arrField = Лист2.Range("Y4").Select
crit = Лист2.Range("Y5:Y14").Value

[/vba] и [vba]

Код

With pt.PivotFields("[Товар].[_Код товара].[" & arrField(1, f) & "]")

[/vba] , выскочила новая ошибка в [vba]

Код

For f = 1 To UBound(arrField, 2)

[/vba]
За ссылку спасибо, читаю.

К сообщению приложен файл: 6198130.png (118.1 Kb)

Ответить

Дата: Понедельник, 13.07.2020, 18:22 | Сообщение № 15

Группа: Пользователи

Ранг: Новичок

Сообщений: 34

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Pelena, Если оставить прежними[vba]

Код

arrField = Лист2.Range("X4:Y4").Value
crit = Лист2.Range("X5:Y14").Value

[/vba]то выдаёт ошибку в этой же строке [vba]

Код

With pt.PivotFields("[Товар].[_Код товара].[" & arrField(1, f) & "]")

[/vba]

К сообщению приложен файл: 7312585.png (95.5 Kb)

Ответить

Дата: Понедельник, 13.07.2020, 18:35 | Сообщение № 16

Группа: Админы

Ранг: Местный житель

Сообщений: 19404

Репутация: 4555 ±

Замечаний: ±

Excel 365 & Mac Excel

Не, ну там же и дальше надо по аналогии исправлять.
Этого цикла, наверное, не будет, если сразу можно использовать VisibleItemsList
[vba]

Код

                        For Each it In .PivotItems
                            If odic.Exists(it.Value) Then .PivotItems(it.Value).Visible = True Else .PivotItems(it.Value).Visible = False
                        Next it

[/vba]

[vba]

Код

arrField = Лист2.Range("Y4").Select

[/vba]
Select тут не нужен, было Value

Я без файла вряд ли Вам помогу

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816

Ответить

Дата: Вторник, 14.07.2020, 11:10 | Сообщение № 17

Группа: Пользователи

Ранг: Новичок

Сообщений: 34

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Нашёл в интернете вот такой вот код, но он тоже не работает [vba]

Код

Sub SKU_2()

Sheets("Куб1").Select

'Вводим переменную КОЛИЧЕСТВА СТРОК ПО СКЮ и считаем количество не пустых строк для дальнейших циклов
Dim CountRowSKU As Long
    CountRowSKU = Cells(Rows.Count, 2).End(xlUp).Row - 2

'Вводим переменную КОЛИЧЕСТВА СТРОК ПО БЮ и считаем количество не пустых строк для дальнейших циклов
Dim CountRowBU As Long
    CountRowBU = Cells(Rows.Count, 5).End(xlUp).Row - 2

'Для проверки количества строк выводим сообщения (убрать комментирование)
'MsgBox CountRowSKU
'MsgBox CountRowBU

'Далее все относительно СКЮ
'Проверяем наличие в строках СКЮ (если СКЮ нет, то переменная = -1, см. выше)
If CountRowSKU <> -1 Then
Sheets("Куб1").Select

'Вводим переменную массива с неопределенным размером
Dim ArrSKU()
'Определяем размер с помощью переменной
ReDim ArrSKU(0 To CountRowSKU)

'Вводим переменную для индексации
Dim SKU As Integer

'Определяем количество итераций - столько же, сколько и кодов
    For SKU = 0 To CountRowSKU
'Определяем значения массива по циклу
        ArrSKU(SKU) = "[Товар].[_Код товара].&[" & Range("I" & SKU + 2).Value & "]"
    Next SKU

'Осуществляем выборку из куба, где значениями будут данные из массива
Sheets("Куб1").Select
    ActiveSheet.PivotTables("СводнаяТаблица2").PivotFields( _
        "[Товар].[_Код товара].[_Код товара]").VisibleItemsList = ArrSKU
End If

'Далее все относится к БЮ. Аналогично СКЮ
If CountRowBU <> -1 Then
Sheets("Куб1").Select
Dim ArrBU()
ReDim ArrBU(0 To CountRowBU)
Dim BU As Integer

    For BU = 0 To CountRowBU
        ArrBU(BU) = "[Канал продаж].[Канал продаж].&[" & Range("J" & BU + 2).Value & "]"
    Next BU

'For BU = 0 To 2
'MsgBox ArrBU(BU)
'   Next BU

Sheets("Куб1").Select
    ActiveSheet.PivotTables("СводнаяТаблица2").PivotFields( _
        "[Канал продаж].[Канал продаж].[Канал продаж]").VisibleItemsList = ArrBU
End If

Sheets("Куб1").Select

End Sub

[/vba] ошибку выдаёт в [vba]

Код

ActiveSheet.PivotTables("СводнаяТаблица2").PivotFields( _
"[Товар].[_Код товара].[_Код товара]").VisibleItemsList = ArrSKU

[/vba]

Нашёл в интернете вот такой вот код, но он тоже не работает [vba]

Код

Sub SKU_2()

Sheets("Куб1").Select

'Вводим переменную КОЛИЧЕСТВА СТРОК ПО СКЮ и считаем количество не пустых строк для дальнейших циклов
Dim CountRowSKU As Long
    CountRowSKU = Cells(Rows.Count, 2).End(xlUp).Row - 2

'Вводим переменную КОЛИЧЕСТВА СТРОК ПО БЮ и считаем количество не пустых строк для дальнейших циклов
Dim CountRowBU As Long
    CountRowBU = Cells(Rows.Count, 5).End(xlUp).Row - 2

'Для проверки количества строк выводим сообщения (убрать комментирование)
'MsgBox CountRowSKU
'MsgBox CountRowBU

'Далее все относительно СКЮ
'Проверяем наличие в строках СКЮ (если СКЮ нет, то переменная = -1, см. выше)
If CountRowSKU <> -1 Then
Sheets("Куб1").Select

'Вводим переменную массива с неопределенным размером
Dim ArrSKU()
'Определяем размер с помощью переменной
ReDim ArrSKU(0 To CountRowSKU)

'Вводим переменную для индексации
Dim SKU As Integer

'Определяем количество итераций - столько же, сколько и кодов
    For SKU = 0 To CountRowSKU
'Определяем значения массива по циклу
        ArrSKU(SKU) = "[Товар].[_Код товара].&[" & Range("I" & SKU + 2).Value & "]"
    Next SKU

'Осуществляем выборку из куба, где значениями будут данные из массива
Sheets("Куб1").Select
    ActiveSheet.PivotTables("СводнаяТаблица2").PivotFields( _
        "[Товар].[_Код товара].[_Код товара]").VisibleItemsList = ArrSKU
End If

'Далее все относится к БЮ. Аналогично СКЮ
If CountRowBU <> -1 Then
Sheets("Куб1").Select
Dim ArrBU()
ReDim ArrBU(0 To CountRowBU)
Dim BU As Integer

    For BU = 0 To CountRowBU
        ArrBU(BU) = "[Канал продаж].[Канал продаж].&[" & Range("J" & BU + 2).Value & "]"
    Next BU

'For BU = 0 To 2
'MsgBox ArrBU(BU)
'   Next BU

Sheets("Куб1").Select
    ActiveSheet.PivotTables("СводнаяТаблица2").PivotFields( _
        "[Канал продаж].[Канал продаж].[Канал продаж]").VisibleItemsList = ArrBU
End If

Sheets("Куб1").Select

End Sub

[/vba] ошибку выдаёт в [vba]

Код

ActiveSheet.PivotTables("СводнаяТаблица2").PivotFields( _
"[Товар].[_Код товара].[_Код товара]").VisibleItemsList = ArrSKU

[/vba]Bodrichkom

Ответить

СообщениеНашёл в интернете вот такой вот код, но он тоже не работает [vba]

Код

Sub SKU_2()

Sheets("Куб1").Select

'Вводим переменную КОЛИЧЕСТВА СТРОК ПО СКЮ и считаем количество не пустых строк для дальнейших циклов
Dim CountRowSKU As Long
    CountRowSKU = Cells(Rows.Count, 2).End(xlUp).Row - 2

'Вводим переменную КОЛИЧЕСТВА СТРОК ПО БЮ и считаем количество не пустых строк для дальнейших циклов
Dim CountRowBU As Long
    CountRowBU = Cells(Rows.Count, 5).End(xlUp).Row - 2

'Для проверки количества строк выводим сообщения (убрать комментирование)
'MsgBox CountRowSKU
'MsgBox CountRowBU

'Далее все относительно СКЮ
'Проверяем наличие в строках СКЮ (если СКЮ нет, то переменная = -1, см. выше)
If CountRowSKU <> -1 Then
Sheets("Куб1").Select

'Вводим переменную массива с неопределенным размером
Dim ArrSKU()
'Определяем размер с помощью переменной
ReDim ArrSKU(0 To CountRowSKU)

'Вводим переменную для индексации
Dim SKU As Integer

'Определяем количество итераций - столько же, сколько и кодов
    For SKU = 0 To CountRowSKU
'Определяем значения массива по циклу
        ArrSKU(SKU) = "[Товар].[_Код товара].&[" & Range("I" & SKU + 2).Value & "]"
    Next SKU

'Осуществляем выборку из куба, где значениями будут данные из массива
Sheets("Куб1").Select
    ActiveSheet.PivotTables("СводнаяТаблица2").PivotFields( _
        "[Товар].[_Код товара].[_Код товара]").VisibleItemsList = ArrSKU
End If

'Далее все относится к БЮ. Аналогично СКЮ
If CountRowBU <> -1 Then
Sheets("Куб1").Select
Dim ArrBU()
ReDim ArrBU(0 To CountRowBU)
Dim BU As Integer

    For BU = 0 To CountRowBU
        ArrBU(BU) = "[Канал продаж].[Канал продаж].&[" & Range("J" & BU + 2).Value & "]"
    Next BU

'For BU = 0 To 2
'MsgBox ArrBU(BU)
'   Next BU

Sheets("Куб1").Select
    ActiveSheet.PivotTables("СводнаяТаблица2").PivotFields( _
        "[Канал продаж].[Канал продаж].[Канал продаж]").VisibleItemsList = ArrBU
End If

Sheets("Куб1").Select

End Sub

[/vba] ошибку выдаёт в [vba]

Код

ActiveSheet.PivotTables("СводнаяТаблица2").PivotFields( _
"[Товар].[_Код товара].[_Код товара]").VisibleItemsList = ArrSKU

[/vba]

Автор - Bodrichkom
Дата добавления - 14.07.2020 в 11:10

Дата: Вторник, 14.07.2020, 11:48 | Сообщение № 18

Группа: Пользователи

Ранг: Новичок

Сообщений: 34

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Pelena, В итоге сейчас код выглядит так [vba]

Код

Sub ОбновлениеСводной()
'Шаг 1: Объявляем переменные
    Dim ws As Worksheet
    Dim pt As PivotTable, crit, i&, f&, it As PivotItem, arrField
    Dim odic As Object
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    arrField = Лист2.Range("X4:Y4").Value
    crit = Лист2.Range("X5:Y14").Value
    'Шаг 2: Запускаем цикл через каждый лист книги
    For Each ws In ThisWorkbook.Worksheets
        'Шаг 3: Запускаем цикл через все сводные таблицы
        For Each pt In ws.PivotTables
            For f = 1 To UBound(arrField, 2)
                Set odic = CreateObject("Scripting.Dictionary")
                For i = 1 To UBound(crit)
                    If crit(i, f) <> "" Then odic("[Товар].[_Код товара].[" & FDynVal(crit(i, f) & "]")) = "[Товар].[_Код товара].[" & FDynVal(crit(i, f) & "]")
                Next i
                With pt.PivotFields("[Товар].[_Код товара].[" & arrField(1, f) & "]")
                    .ClearAllFilters
                    If odic.Count > 0 Then
                        For Each it In .PivotItems
                            If odic.Exists(it.Value) Then .PivotItems(it.Value).Visible = True Else .PivotItems(it.Value).Visible = False
                        Next it
                    End If
                End With
            Next f
        Next pt
    Next ws
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub
Public Function FDynVal(FrmContrVal)
If Len(FrmContrVal & "") = 0 Then
    FDynVal = ""
Else
    Select Case VarType(FrmContrVal)
    Case 5
        FDynVal = CStr(FrmContrVal)
    Case 8
        FDynVal = FrmContrVal
    Case 7
        FDynVal = Format(FrmContrVal, "m\/d\/yyyy")
    End Select
End If
End Function

[/vba]

Ошибка в [vba]

Код

With pt.PivotFields("[Товар].[_Код товара].[" & arrField(1, f) & "]")

[/vba]

Pelena, В итоге сейчас код выглядит так [vba]

Код

Sub ОбновлениеСводной()
'Шаг 1: Объявляем переменные
    Dim ws As Worksheet
    Dim pt As PivotTable, crit, i&, f&, it As PivotItem, arrField
    Dim odic As Object
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    arrField = Лист2.Range("X4:Y4").Value
    crit = Лист2.Range("X5:Y14").Value
    'Шаг 2: Запускаем цикл через каждый лист книги
    For Each ws In ThisWorkbook.Worksheets
        'Шаг 3: Запускаем цикл через все сводные таблицы
        For Each pt In ws.PivotTables
            For f = 1 To UBound(arrField, 2)
                Set odic = CreateObject("Scripting.Dictionary")
                For i = 1 To UBound(crit)
                    If crit(i, f) <> "" Then odic("[Товар].[_Код товара].[" & FDynVal(crit(i, f) & "]")) = "[Товар].[_Код товара].[" & FDynVal(crit(i, f) & "]")
                Next i
                With pt.PivotFields("[Товар].[_Код товара].[" & arrField(1, f) & "]")
                    .ClearAllFilters
                    If odic.Count > 0 Then
                        For Each it In .PivotItems
                            If odic.Exists(it.Value) Then .PivotItems(it.Value).Visible = True Else .PivotItems(it.Value).Visible = False
                        Next it
                    End If
                End With
            Next f
        Next pt
    Next ws
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub
Public Function FDynVal(FrmContrVal)
If Len(FrmContrVal & "") = 0 Then
    FDynVal = ""
Else
    Select Case VarType(FrmContrVal)
    Case 5
        FDynVal = CStr(FrmContrVal)
    Case 8
        FDynVal = FrmContrVal
    Case 7
        FDynVal = Format(FrmContrVal, "m\/d\/yyyy")
    End Select
End If
End Function

[/vba]

Ошибка в [vba]

Код

With pt.PivotFields("[Товар].[_Код товара].[" & arrField(1, f) & "]")

[/vba]Bodrichkom

Ответить

СообщениеPelena, В итоге сейчас код выглядит так [vba]

Код

Sub ОбновлениеСводной()
'Шаг 1: Объявляем переменные
    Dim ws As Worksheet
    Dim pt As PivotTable, crit, i&, f&, it As PivotItem, arrField
    Dim odic As Object
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    arrField = Лист2.Range("X4:Y4").Value
    crit = Лист2.Range("X5:Y14").Value
    'Шаг 2: Запускаем цикл через каждый лист книги
    For Each ws In ThisWorkbook.Worksheets
        'Шаг 3: Запускаем цикл через все сводные таблицы
        For Each pt In ws.PivotTables
            For f = 1 To UBound(arrField, 2)
                Set odic = CreateObject("Scripting.Dictionary")
                For i = 1 To UBound(crit)
                    If crit(i, f) <> "" Then odic("[Товар].[_Код товара].[" & FDynVal(crit(i, f) & "]")) = "[Товар].[_Код товара].[" & FDynVal(crit(i, f) & "]")
                Next i
                With pt.PivotFields("[Товар].[_Код товара].[" & arrField(1, f) & "]")
                    .ClearAllFilters
                    If odic.Count > 0 Then
                        For Each it In .PivotItems
                            If odic.Exists(it.Value) Then .PivotItems(it.Value).Visible = True Else .PivotItems(it.Value).Visible = False
                        Next it
                    End If
                End With
            Next f
        Next pt
    Next ws
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub
Public Function FDynVal(FrmContrVal)
If Len(FrmContrVal & "") = 0 Then
    FDynVal = ""
Else
    Select Case VarType(FrmContrVal)
    Case 5
        FDynVal = CStr(FrmContrVal)
    Case 8
        FDynVal = FrmContrVal
    Case 7
        FDynVal = Format(FrmContrVal, "m\/d\/yyyy")
    End Select
End If
End Function

[/vba]

Ошибка в [vba]

Код

With pt.PivotFields("[Товар].[_Код товара].[" & arrField(1, f) & "]")

[/vba]

Автор - Bodrichkom
Дата добавления - 14.07.2020 в 11:48

Дата: Вторник, 14.07.2020, 11:58 | Сообщение № 19

Группа: Админы

Ранг: Местный житель

Сообщений: 19404

Репутация: 4555 ±

Замечаний: ±

Excel 365 & Mac Excel

По Вашему файлу надо внести исправления. На примере Заказчика
[vba]

Код

CountRowBU = Cells(Rows.Count, 7).End(xlUp).Row - 6

[/vba]
[vba]

Код

ArrSKU(SKU) = "[Заказчик].[_Код заказчика].&[" & Range("G" & SKU + 6).Value & "]"

[/vba]
Заказчик и _Код заказчика поставила наобум, надо изменить на адекватные

Используйте тот код, что нашли, только внесите исправления. Файл имеется в виду, тот, что был приложен. Если критерии расположены по-другому, считайте сами, с какого столбца и с какой строки начинать

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816

Ответить

Дата: Вторник, 14.07.2020, 12:11 | Сообщение № 20

Группа: Пользователи

Ранг: Новичок

Сообщений: 34

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Pelena, выдаёт ошибку [vba]

Код

ActiveSheet.PivotTables("СводнаяТаблица2").PivotFields( _
"[Товар].[_Код товара].[_Код товара]").VisibleItemsList = ArrSKU

[/vba]
Может всё же первый код допилим))) а то этот в конечном итоге не совсем тот результат давать будет(

Ответить

Фильтрация во всех листах по заданному значению (Макросы/Sub)

Страница 1 из 2
1
2
»

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