A Neat Trick/Macro for More Readable Pivots

Good one! I’ve found myself doing this manually a number of times but not often enough to work my way thru a macro (also not an advanced coder).

With a little addition to your code, you can have this prompt the user for input on the column width so you can easily adjust without changing the code:

Sub ShrinkColumnsToReadable()
Dim oPivot As PivotTable
Set oPivot = ActiveCell.PivotTable
Dim oColRange As Range
Set oColRange = FindColumnLabelsRange(ActiveSheet.Name, oPivot.Name)
oColRange.Columns.Select
Dim sUserInput As String

‘Ask user how wide to make the columns
sUserInput = InputBox(“Enter Column Width (1-255):”, “User Input for Column Width”)

‘test input before continuing to validate the input
If Not (Len(sUserInput) > 0 And IsNumeric(sUserInput) And sUserInput 0) Then
MsgBox “Input not valid, code aborted.”, vbCritical
Exit Sub
End If

‘Increase this number for wider columns, smaller for narrower
Selection.ColumnWidth = sUserInput

oColRange.Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

‘Turn AutoFit Column Width on Update OFF
oPivot.HasAutoFormat = False

End Sub

Function FindColumnLabelsRange(sSheet As String, sPivot As String) As Range
Dim oSheet As Worksheet
Dim oPivot As PivotTable

Set oSheet = ActiveWorkbook.Sheets(sSheet)
Set oPivot = oSheet.PivotTables(sPivot)

Set FindColumnLabelsRange = oPivot.ColumnRange
End Function

Brilliant post! I do this constantly, although rather than want my columns all the same width, I generally just make them 2 or 3 rows deep and then have the various widths that results in (so each column has a different width depending on length, but they all get condensed based on a uniform, increased row depth). This has the benefit of minimizing screen width, but at the cost of a less slick format which you achieve.

I played around with the code to get something that works for this desire. It’s basically the same but with row height instead of column width, although there are a couple of additional lines of code at the end which AutoFit in order to get this result.

Sub ShrinkColumnsToReadable2()
Dim oPivot As PivotTable
Set oPivot = ActiveCell.PivotTable
Dim oColRange As Range
Set oColRange = FindColumnLabelsRange(ActiveSheet.Name, oPivot.Name)
oColRange.Columns.Select
Dim sUserInput As String

‘ Ask user how high to make the rows – have found 55 is good for 3 rows deep and 35 good for 2 rows deep
sUserInput = InputBox(“Enter Row Height (1-255):”, “User Input for Row Height”)

‘ test input before continuing to validate the input
If Not (Len(sUserInput) > 0 And IsNumeric(sUserInput) 0) Then
MsgBox “Input not valid, code aborted.”, vbCritical
Exit Sub
End If

‘ Increase this number for wider columns, smaller for narrower

Selection.RowHeight = sUserInput

oColRange.Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = True
.ReadingOrder = xlContext
.MergeCells = False
End With

Selection.ColumnWidth = 1
Selection.EntireColumn.AutoFit

‘ Turn AutoFit Column Width on Update OFF
oPivot.HasAutoFormat = False

End Sub

Function FindColumnLabelsRange(sSheet As String, sPivot As String) As Range
Dim oSheet As Worksheet
Dim oPivot As PivotTable

Set oSheet = ActiveWorkbook.Sheets(sSheet)
Set oPivot = oSheet.PivotTables(sPivot)

Set FindColumnLabelsRange = oPivot.ColumnRange
End Function

Thanks again legends!