Переименовать значения фильтра

Question

У меня есть макрос, который должен изменить фильтр «WEEK» на 5 сводных таблицах на листе «veckorapport».

Этот макрос каким-то образом меняет «имя» в неделях на число / текст, который я помещаю в поле ввода. Смотрите первое изображение, эти цифры должны быть в порядке убывания.

Мой код:

Sub Veckorapport_filter()
Dim num As String
Dim sht As Worksheet
Set sht = Sheets("Veckorapport")
num = InputBox(Prompt:="Vecka", Title:="ENTER WEEK")
sht.PivotTables("PivotTable1") _
    .PivotFields("WEEK").CurrentPage = num
sht.PivotTables("PivotTable2") _
    .PivotFields("WEEK").CurrentPage = num
sht.PivotTables("PivotTable3") _
    .PivotFields("WEEK").CurrentPage = num
sht.PivotTables("PivotTable4") _
    .PivotFields("WEEK").CurrentPage = num
sht.PivotTables("PivotTable5") _
    .PivotFields("WEEK").CurrentPage = num
End Sub

Мне нужна помощь с двумя вещами: Как я могу написать этот код, чтобы он не менял «имя» в течение недель в фильтре?

И 2-й: Как я могу заменить имена на правильные имена в списке фильтров?

Ссылка на картинку: https://imgur.com/kndEnm6

РЕДАКТИРОВАТЬ: Изображение, как оно должно выглядеть: https://imgur.com/CU9fWex

РЕДАКТИРОВАТЬ 2: Эти две недели поменялись местами. Должно быть в порядке убывания: https://imgur.com/PVS3JMf

Answer 1

Если вы измените .CurrentPage на что-то, что не существует , то вместо этого он переименует текущую выбранную страницу / элемент. (Если вы сделаете это вручную, а не через VBA, вы получите окно подтверждения: «В отчете сводной таблицы нет элемента с таким именем. Переименуйте« Old_Name »в« New_Name »?» С помощью «OK» и «Отмена» кнопка "

Вы можете частично предотвратить это, включив для этого поля «Показать элементы без данных», и / или вы можете использовать WorksheetFunction.CountIf, чтобы проверить, существует ли это значение, перед изменением .CurrentPage

Что касается сброса элементов: установите .Name, .Value или .Caption из PivotItem обратно на SourceName:

Dim piTMP AS PivotItem, pfTMP AS PivotField
Set pfTMP = sht.PivotTables("PivotTable1").PivotFields("WEEK")
For Each piTMP In pfTMP.PivotItems
    piTMP.Name = piTMP.SourceName
Next piTMP

Если имена были изменены для 2 элементов, вы столкнетесь с проблемой (одно и то же имя не может существовать дважды), поэтому вам нужно либо проверить используемое имя, либо просто перебить его 2 циклы - что, вероятно, является более простым решением для записи:

Dim piTMP AS PivotItem, pfTMP AS PivotField
Set pfTMP = sht.PivotTables("PivotTable1").PivotFields("WEEK")
'Once through
For Each piTMP In pfTMP.PivotItems
    piTMP.Name = piTMP.SourceName & "_AndSomeTextThatYouNeverUse"
Next piTMP
'Twice through
For Each piTMP In pfTMP.PivotItems
    piTMP.Name = piTMP.SourceName
Next piTMP

Answer 2

Чтобы просмотреть все сводные таблицы на листе:

Sub Veckorapport_filter()
Dim num As String
Dim sht As Worksheet
Set sht = Sheets("Veckorapport")
num = InputBox(Prompt:="Vecka", Title:="ENTER WEEK")
If len(num) <> 0 then
  dim pt as pivottable
  for each pt in sht.pivottables
    with pt.PivotFields("WEEK")
       .clearallfilters
      .CurrentPage = num
    end with
  next pt
 end if
End Sub