Mrrrr's Forum (VIEW ONLY)
Un forum care ofera solutii pentru unele probleme legate in general de PC. Pe langa solutii, aici puteti gasi si alte lucruri interesante // A forum that offers solutions to some PC related issues. Besides these, here you can find more interesting stuff.
|
Lista Forumurilor Pe Tematici
|
Mrrrr's Forum (VIEW ONLY) | Reguli | Inregistrare | Login
POZE MRRRR'S FORUM (VIEW ONLY)
Nu sunteti logat.
|
Nou pe simpatie:
Manuela25 pe Simpatie.ro
 | Femeie
25 ani
Bucuresti
cauta Barbat
25 - 62 ani |
|
|
TRaP
Moderator
Inregistrat: acum 6 ani
Postari: 787
|
|
This will make all fields in table Tabular and set Subtotals to none showing a more table-like pivot.
Sub PIVOT_All_Tabular()
Application.ScreenUpdating = False
Dim pt As PivotTable
Dim pf As PivotField
'Set pt = ActiveSheet.PivotTables(1) --- REPLACED WITH THE ONE BELOW
Set pt = ActiveCell.PivotTable ' this makes sure it works for the selected pivot table
For Each pf In pt.PivotFields
pf.LayoutForm = xlTabular
pf.Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
Next pf
Application.ScreenUpdating = True
End Sub
|
Modificat de TRaP (acum 4 ani)
|
|
| pus acum 4 ani |
|
|
TRaP
Moderator
Inregistrat: acum 6 ani
Postari: 787
|
|
updated to work for the selected table
|
|
| pus acum 4 ani |
|
|
TRaP
Moderator
Inregistrat: acum 6 ani
Postari: 787
|
|
In order to remove grand totals and repeat item labels in tabular form, add the following snippet before Application.ScreenUpdating = True.
With pt
.ColumnGrand = False
.RowGrand = False
.RowAxisLayout xlTabularRow
.RepeatAllLabels xlRepeatLabels
End With |
|
|
| pus acum 3 ani |
|
|
TRaP
Moderator
Inregistrat: acum 6 ani
Postari: 787
|
|
The following code removes all subtitles and makes the Pivot Table in classic form.
Works in any file and for any pivot table in any Excel file.
If more than one Pivot Table in sheet, it will ask you if you want to do it for all Pivot tables.
If you say no, then you must select a cell from the desired Pivot table for it to work. If not already selected, it will tell you that end exit code.
Sub PIVOT_Classic_No_Subtotals()
Application.ScreenUpdating = False
Dim pt As PivotTable
Dim pf As PivotField
If ActiveSheet.PivotTables.count = 1 Then
Set pt = ActiveSheet.PivotTables(1)
Else
Message = MsgBox("Vrei sa faci asta in toate fisierele Pivot din acest Sheet?", vbYesNo)
If Message = vbYes Then
GoTo ptLoop
Else
On Error GoTo ptErr
Set pt = ActiveCell.PivotTable
End If
End If
For Each pf In pt.PivotFields
On Error Resume Next
If Left(pf.Formula, 1) <> "=" Then
pf.Subtotals(1) = False ' pf.Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
pf.LayoutForm = xlTabular
End If
Next pf
With pt
.InGridDropZones = True
.ColumnGrand = False
.RowGrand = False
.RowAxisLayout xlTabularRow
'.RepeatAllLabels xlRepeatLabels
End With
Application.ScreenUpdating = True
Exit Sub
ptErr:
MsgBox "In acest Sheet sunt " & ActiveSheet.PivotTables.count & " tabele Pivot" & vbCrLf & vbCrLf & _
"Trebuie sa dai click intr-o celula din tabelul Pivot dorit," & vbCrLf & _
"apoi sa dai din nou pe buton pentru eliminare subtotaluri."
Exit Sub
ptLoop:
Application.ScreenUpdating = False
Dim sh As Worksheet
Set sh = ActiveSheet
'For Each sh In ThisWorkbook.Worksheets ---- loop through all pivot tables in the current workbook / remove above sh = ActiveSheet
For Each pt In sh.PivotTables
For Each pf In pt.PivotFields
On Error Resume Next
If Left(pf.Formula, 1) <> "=" Then
pf.Subtotals(1) = False ' pf.Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
pf.LayoutForm = xlTabular
End If
Next pf
Next pt
'Next sh '---- in case you want to loop through all pivot tables in the current workbook
With pt
.InGridDropZones = True
.ColumnGrand = False
.RowGrand = False
.RowAxisLayout xlTabularRow
'.RepeatAllLabels xlRepeatLabels
End With
Application.ScreenUpdating = True
Exit Sub
End Sub |
|
|
| pus acum 1 an |
|