Excel VBA: как добавить новое поле с формулой в сводную таблицу?

Question

создать сводную таблицу:

ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=Sheets("Working").UsedRange).CreatePivotTable TableDestination:="", TableName:="HDPivotTable", DefaultVersion:=xlPivotTableVersion10 
ActiveSheet.Name = "HD Pivot" 

ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(1, 1) 

ActiveSheet.PivotTables("HDPivotTable").AddFields RowFields:="Location Code" 

ActiveSheet.PivotTables("HDPivotTable").PivotFields("h,d,x").Orientation = xlDataField 


With ActiveSheet.PivotTables("HDPivotTable").PivotFields("h,d,x") 
    .Orientation = xlColumnField 

    For i = 1 To .PivotItems.Count 
     ' Filter out columns that are not "D" or "H" 
     If .PivotItems(i) <> "D" And .PivotItems(i) <> "H" Then 
      .PivotItems(i).Visible = False 
     End If 
    Next  

End With 

Так результирующая таблица выглядит следующим образом:

Мне нужно добавить новый столбец «T/F» после Великого Всего, что было бы TRUE, если значения в столбцах «D» и «H» равны, а FALSE в противном случае. У меня он красный и подсвеченный. Я не могу заставить его работать, что бы я ни пытался. Я не эксперт в VBA или Excel, поэтому я мог бы попробовать все, что нашел в Интернете. Не могли бы вы помочь?

Спасибо.

Answer 1

Это вернет 1, если TRUE или 0 если есть FALSE.

ActiveSheet.PivotTables("HDPivotTable").CalculatedFields.Add "Compare", "=Monto ='D/Monto'", True 
    'Where: 
    'Compare : Is the name of the field (you use "T/F") 
    '"=Monto = 'D/Monto'" : Is the comparison of fields you want in your case would be 
    '"=D = H" <== that way 
ActiveSheet.PivotTables("HDPivotTable").PivotFields("Compare").Orientation = xlDataField 
    'Here you add the field to the pivot 

Edit # 1 ПримечаниеЭтот: В первой строке добавить поле, и так как не может быть два поля с одинаковым именем, если вы запустите макрос дважды, вы получите сообщение об ошибке в первая строка.

Если вы уже создали поле («Сравнить», используя мой пример), вам нужно только добавить fiel к xlDataField.

Edit 2

Просто решили изменить эти вопросы ...

Sub addComp() 

    Dim r 'to store the last row 
    Dim c 'to store the last column 

    c = Application.WorksheetFunction.Match("Grand Total", Range("A3").EntireRow, 0) 
     'to find the last column of the pivot 
     'in your case would be "Grand Total" 
     'if add 1 to c, we get the column next to the pivot 
     ' 
     'In my example, I use my own header, but you can use yours. 
     'In your question you use "Grand total", i change it. 
     ' 
     'And that is why you get and error, becuase MATCH was looking for "Sum of D/Monto", 
     'not "Grand total" 
    r = Range(Cells(3, c), Cells(3, c)).End(xlDown).Row 
     'here I use the 3th row because, in my case my pivot is in the 
     '3th row, but you can use the row you want/need 
     'that range/row, is the reference that use the pivot to set its position 
     'inside the worksheet. 
     'And using that row as a reference, whith the code 
     'r = Range(Cells(3, c), Cells(3, c)).End(xlDown).Row I just find the last row down 
     'no matter how many rows be. Is like, to manually got to the "Grand total" header, 
     'press Shift+DownArrow, and you will go to the last row, the code above do the very same. 
     ' 
     'To find the las row of the pivot 

    Range(Cells(3, c + 1), Cells(3, c + 1)).Value = "T/F" 
     'Here adds the name of our field 
    Range(Cells(4, c + 1), Cells(r - 1, c + 1)).FormulaR1C1 = "=RC[-2]=RC[-1]" 
     'Here add the TRUE/FALSE to all the cells in the next column of the pivot. 
     'I don't use the formula with the Grand total row, but if you want, 
     'just remove the " - 1" next to r in the second Cells 
End Sub 

Edit # 3

Sub addComp() 
    Dim r 'to store the last row 
    Dim c 'to store the last column 
    c = Application.WorksheetFunction.Match("Grand Total", Range("A2").EntireRow, 0) 
    r = Range(Cells(2, c), Cells(2, c)).End(xlDown).Row 
    Range(Cells(2, c + 1), Cells(2, c + 1)).Value = "T/F" 
    Range(Cells(3, c + 1), Cells(r - 1, c + 1)).FormulaR1C1 = "=RC[-2]=RC[-1]" 
End Sub