Lazy VBA

The one-click number auto format

2012-12-16T18:28:00.000+00:00

How many times do you right click, format cell, number format, no decimals....?
Select a range, launch the macro: all numbers are formatted according to rules explained below.
Best part: if you select a cell that is part of a pivot datafield, it will format the whole value field (equivalent of value field settings- number format).
Time and sanity saver on a daily basis. Tested on Excel 2003 and Excel 2010.

It is tweaked for my usage but feel free to adapt it, playing on conditions and format output (end of the macro). Final format will be as good as your rules.

Rules Examples:

All values between 1900 and 2020: no decimals, no 1000's separator
All values between -5 and +5: percentage format
No decimals if the sum of the values has no decimals (not perfect but faster than a loop)
Value between first January 1995 and first January 2020: Date format
All values inferior to 10: two decimals if any
All values inferior to 1000 : one decimal if any

For best usage, save it within a personal macro book ( see http://www.rondebruin.nl/personal.htm) and add a shortcut in the Quick Access Toolbar or a keybord shortcut: The macro will be permanently available.

Enjoy and suggest alternative rules in comments.

Sub oneclicknumberformat()
Application.EnableEvents = False
Dim myarray As Variant
Dim rCcells As Range, rFcells As Range, rAcells As Range, rngsel As Range, trng As Range
Dim pt As PivotTable, ptdn As String, nf As String, rCell As Range, df As PivotField
Dim i As Integer

Set rngsel = Selection
Set trng = rngsel
ptdn = "none"

If rngsel.Cells.Count = 1 Then
If rngsel = vbNullString Then Exit Sub
End If

If ActiveSheet.PivotTables.Count > 0 And Selection.Cells.Count = 1 Then
For i = 1 To ActiveSheet.PivotTables.Count
If Not Intersect(Selection, ActiveSheet.PivotTables(i).DataBodyRange) Is Nothing Then
Set pt = ActiveSheet.PivotTables(i)
For Each df In ActiveSheet.PivotTables(i).DataFields
ActiveSheet.PivotTables(i).PivotSelect "'" & df.Name & "'", xlDataOnly
Set trng = Selection
If Not Intersect(rngsel, trng) Is Nothing Then
ptdn = df.Name
trng.ClearFormats
Exit For
End If
Next
Exit For
End If
Next
End If

If ptdn = "none" And Selection.Cells.Count > 1 Then
On Error Resume Next
Set rCcells = rngsel.SpecialCells(xlCellTypeConstants, xlNumbers)
Set rFcells = rngsel.SpecialCells(xlCellTypeFormulas, xlNumbers)
If rCcells Is Nothing And rFcells Is Nothing Then
Exit Sub
ElseIf rCcells Is Nothing Then
Set trng = rFcells
ElseIf rFcells Is Nothing Then
Set trng = rCcells
Else
Set trng = Application.Union(rFcells, rCcells)
End If
On Error GoTo 0
End If

trngmax = Application.Max(trng)
trngmin = Application.Min(trng)
trngmax2 = Application.Max(trngmax, Abs(trngmin))
trngs = Application.Sum(trng)
trngd = trngs - Int(trngs)

If ptdn = "none" And trngmin >= 34700 And trngmax <= 43831 Then
nf = "dd-mmm-yy"
ElseIf ptdn = "none" And trngmin >= 1900 And trngmax <= 2020 Then
nf = "0"

ElseIf trngmax2 < 5 Then
nf = "0%"

ElseIf trngd = 0 Then
nf = "#,##0"
ElseIf trngmax2 < 10 Then
nf = "#,##0.00"
ElseIf trngmax2 < 1000 Then
nf = "#,##0.0"
Else
nf = "#,##0"
End If

If ptdn = "none" Then
trng.Select
trng.NumberFormat = nf
Else
df.NumberFormat = nf
End If
rngsel.Select
Application.EnableEvents = True

End Sub

Little Big Pivot: a pivot compressor

2012-08-17T23:04:00.000+01:00

Back!

Short version:
Creates a lighter copy of the pivot table, removing unwanted fields an values.
So you can share a real pivot table, as you designed it, instead of a useless copy of pivot table.
Lighter (email friendly), cleaner, more performance, no confidentiality issues as unwanted data are not embedded in the new pivot table.

The before & after picture:

The idea is to "slim" a pivot:
The macro aggregates the values used in the pivot table as a new source for the new pivot table.

The new pivot table is an exact copy: same formatting, same custom names, same value formats
Only visible fields ( including page fields on top of pivot) are kept
Filtered values won't be available in the new pivot
You can use the unique count macro with this new pivot, it should be a lot faster and resolves the issues of grouped fields in the http://lazyvba.blogspot.co.uk/2010/11/improve-your-pivot-table-to-count.html

Instructions:

Work on a copy of your document, of course
Paste the code in any module
Prepare your table: Move unwanted fields into the "Pivot Fields List"
Set up your filters
Run the code: two new sheets are created, one with the new pivot, one named "lightdata" with the new aggregated source.

My comments:

Tested briefly on various versions of Excel: 2003, 2007, 2010, feedback welcome.
Grouped and renamed fields are managed
It only works if your data fields are sums! (no average, min, max or other calculations)
Previous pivot tables and sources are still in the workbooks: delete them if your satisfied with the result.
Bug with remote connection to solve

Example can be downloaded here, dummy data (20,000 rows generated via fakenamegenerator.com ).
Code already run, so you can see the result.
A security warning could appear according to your settings: it's still a file with macro downloaded from internet.

Let now know your thoughts, or suggestions to improve our pivot tables, in the comments.

Sub LittleBigPivot()
'by lazyvba.blogspot.com

Dim vArr, arraypos As Variant
Dim pfc, r, c, gt, c2 As Integer
Dim tem As String
Dim datarng, newdata As Range

Dim wb As Workbook, wp, wp2, newdatasheet As Worksheet, _
pt, pt2 As PivotTable, pf, cf, rf As PivotField

Set wb = ActiveWorkbook
Set wp = ActiveSheet
Set pt = wp.PivotTables(1)

Err.Clear
On Error Resume Next
wp.Copy after:=wp
Set wp2 = ActiveSheet
Set pt2 = wp2.PivotTables(1)
pfc = pt2.PivotFields.Count
r = 1
ReDim arraypos(1 To 4, 1 To 1)
For Each pf In pt2.PivotFields
If pf.Orientation <> xlHidden Then

If Err.Number <> 0 Then
GoTo suite
End If
arraypos(4, r) = pf.ChildField.Name
arraypos(1, r) = pf.Name
arraypos(2, r) = pf.Orientation
arraypos(3, r) = pf.Position
ReDim Preserve arraypos(1 To 4, 1 To UBound(arraypos, 2) + 1)
r = r + 1
End If
suite:
Err.Clear
Next

On Error GoTo 0

pt2.ManualUpdate = True
For Each pf In pt2.PageFields
pt2.PivotFields(pf.Name).Orientation = xlRowField
Next
For Each cf In pt2.ColumnFields
pt2.PivotFields(cf.Name).Orientation = xlRowField
Next
On Error Resume Next
pt2.DataPivotField.Orientation = xlColumnField
With pt2
.RowAxisLayout xlTabularRow
.InGridDropZones = True
.DisplayContextTooltips = False
End With
On Error GoTo 0

For Each rf In pt2.RowFields
pt2.PivotFields(rf.Name).Subtotals(1) = True
pt2.PivotFields(rf.Name).Subtotals(1) = False
Next

pt2.ManualUpdate = False

For c = 1 To pt2.RowRange.Columns.Count - 1

pt2.RowRange.Columns(c).Offset(1, 0).Resize(pt2.RowRange.Rows.Count - 1, 1).Select
Selection.ShowDetail = True
Next

If pt2.RowRange.Cells(pt2.RowRange.Rows.Count, 1).Value = "Grand Total" Then
gt = 1
Else
gt = 0
End If

Set datarng = Range(pt2.RowRange.Cells(1, 1), pt2.DataBodyRange. _
Cells(pt2.DataBodyRange.Rows.Count - gt, pt2.DataBodyRange.Columns.Count))
vArr = datarng.Value

For c = 1 To pt2.RowRange.Columns.Count
For r = 2 To datarng.Rows.Count
If IsEmpty(vArr(r, c)) Then
vArr(r, c) = vArr(r - 1, c)
End If
Next
Next

If pt2.DataFields.Count = 1 Then
vArr(1, datarng.Columns.Count) = pt2.DataFields(1).SourceName
Else
For c2 = 1 To datarng.Columns.Count
vArr(1, c2) = pt2.PivotFields(vArr(1, c2)).SourceName
Next
End If

c2 = datarng.Columns.Count

Application.DisplayAlerts = False
wp2.Delete
Application.DisplayAlerts = True

Worksheets.Add
Set newdata = Range(Cells(1, 1), Cells(r - 1, c2))
Set newdatasheet = ActiveSheet
newdata.Value = vArr
ActiveSheet.Name = "lightdata"

wp.Copy after:=wp
Set wp2 = ActiveSheet
Set pt2 = wp2.PivotTables(1)
pt2.ManualUpdate = False

pt2.SourceData = "lightdata!" & newdata.Address(ReferenceStyle:=xlR1C1)
pt2.RefreshTable
If UBound(arraypos, 2) > 1 Then
For r = 1 To UBound(arraypos, 2) - 1
pt2.PivotFields(arraypos(1, r)).Orientation = arraypos(2, r)
pt2.PivotFields(arraypos(1, r)).Position = arraypos(3, r)
Next
End If
pt2.ManualUpdate = True

End Sub

Improve your Excel Pivot Table to count unique values or items

2010-11-18T16:52:00.004+00:00

Short Version:
Updated in November 12, faster execution.
A macro to allow a dynamic unique/distinct count field within your pivot table.
Copy the code, paste it in the right place, just renaming what you want to count.
Refresh the pivot: Done.

No intervention on source data required, factors pivot fields disposition and filters into the count.

I tried to anticipate most of the treacherous actions that treacherous users like you or me could try, to make it as adaptable as possible.

Unimaginative preview of unique customers buying stuff:

Restrictions :
-English Excel 2007 or Excel 2010 only (the macro converts the data source into table format)
-No filter on invisible fields
-Save your file with xlsm extension.
-If you reopen your file, you may have an alert message, click OK, refresh the pivot table.

Also:
-No grouping of values
-Data must be within the workbook (no remote connection to database)
These two restrictions and slow performance can be avoided with the pivot compressor: http://lazyvba.blogspot.co.uk/2012/08/little-big-pivot.html

That’s it, I think.

Installation :
-Create your Pivot Table (only one please)
-Open Visual Basic Editor (Alt+F11)
-Paste the code in the sheet module where is your pivot table (use the tab name) and nowhere else.
-Edit the row « tocount = "name of the field" » and replace name by the field name you want to count
-Come back to Excel
-Do a refresh or a modification on the Pivot : Unik is appearing : that’s the count of unique items!
-Any modification recalculates Unik : Just play with your pivot
-If your’re bored of it, hiding the Unik field stops the code. Put it back in the pivot, it’s counting again.

My comments :
-Totals are false (sum of unique count), but not visible (except collapsed items )
-If nothing happens, events may be disabled : just run the private sub boom at the beginning
-The method is not the most elegant, but I found it to be the fastest
-Code is not commented yet, and so not easily readable, please forgive me

Enjoy and let me know your comments.

The thing:

Private Sub boom()
Application.EnableEvents = True
End Sub

Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
'by lazyvba.blogspot.com
Dim tocount As String

tocount = "name of the field"

Application.EnableEvents = False

Dim wb As Workbook, ws As Worksheet, wd As Worksheet, wp As Worksheet, pt As PivotTable, pf As PivotField _
, pi As PivotItem, str As String, str2 As String, Kode As String, totr As String, totc As String, rng As Range _
, li As ListObject, lo As ListObject, loc As ListColumn, rng1 As Range, rng2 As Range, t As Integer
Dim rf As Integer

Set wb = ActiveWorkbook
Set wp = ActiveSheet
Set pt = wp.PivotTables(1)
pt.Name = "PT"
t = 0
For Each ws In wb.Worksheets
For Each li In ws.ListObjects
If li.Name = pt.SourceData Then
li.Name = "Datas"
Set lo = li
t = 1
End If
Next li
Next ws

If t = 0 Then
For Each ws In wb.Worksheets
On Error Resume Next
Set wd = ws.Range(Application.ConvertFormula(pt.SourceData _
, fromreferencestyle:=xlR1C1, toreferencestyle:=xlA1)).Parent
On Error GoTo 0
Next ws

If wd.ListObjects.Count = 0 Then
wd.ListObjects.Add(xlSrcRange, wd.Range(Application.ConvertFormula _
(pt.SourceData, fromreferencestyle:=xlR1C1, toreferencestyle:=xlA1 _
)), , xlYes).Name = "Datas"
Else
wd.ListObjects(1).Name = "Datas"
End If
Set lo = wd.ListObjects("Datas")
End If

t = 0
For Each pf In pt.PivotFields
If pf.Name = "Unik" Then t = 1
Next pf
If t = 1 Then GoTo testunik

Setup:
lo.ListColumns.Add
lo.ListColumns(lo.ListColumns.Count).Name = "Visi"
lo.ListColumns.Add
lo.ListColumns(lo.ListColumns.Count).Name = "Kode"
lo.ListColumns.Add
lo.ListColumns(lo.ListColumns.Count).Name = "Unik"

With pt
.ChangePivotCache ActiveWorkbook.PivotCaches. _
Create(SourceType:=xlDatabase, SourceData:="Datas", Version:= _
xlPivotTableVersion12)
.PivotCache.Refresh
.InGridDropZones = True
.RowAxisLayout xlTabularRow
End With

With pt.PivotFields("Unik")
.Orientation = 4
.Caption = " Unik"
.Function = xlSum
End With

testunik:
t = 0
For Each pf In pt.DataFields
If InStrB(pf.Name, "Unik") > 0 Then
t = 1
If pf.Name <> " Unik" Then
With pf
.Caption = " Unik"
.Function = xlSum
End With
End If
End If
Next pf
If t = 0 Then
Application.EnableEvents = True
Exit Sub
End If

Kode = ""
With pt
For Each pf In pt.PageFields
If pf.AllItemsVisible = False Then
For Each pi In pf.PivotItems
If pi.Visible = False Then
If Kode = "" Then
Kode = "[" & pf.Name & "]" & "<>" & """" & pi.Name & """"
Else
Kode = Kode & "," & "[" & pf.Name & "]" & "<>" & """" & pi.Name & """"
End If
End If
Next pi
End If
Next pf
End With

If Kode = "" Then
Kode = 1
Else
Kode = "=IF(and(" & Kode & "),1,0)"
End If

With lo.ListColumns("Visi").DataBodyRange
.Value = Kode
.Value = .Value
End With

Kode = ""
For Each pf In pt.RowFields
If pf.Name <> "Data" And pf.Name <> "Values" Then
Kode = Kode & "[" & pf.Name & "]&"
End If
Next pf

For Each pf In pt.ColumnFields
If pf.Name <> "Data" And pf.Name <> "Values" Then
Kode = Kode & "[" & pf.Name & "]&"
End If
Next pf

If Right(Kode, 1) = "&" Then
Kode = Left(Kode, Len(Kode) - 1)
Kode = "=IF([Visi]=1," & Kode & "&[" & tocount & "],0)"
End If
If Kode = "" Then
Kode = "=IF([Visi]=1,[" & tocount & "],0)"
End If

With lo
.ListColumns("Kode").DataBodyRange.FormulaR1C1 = Kode
.ListColumns("Kode").DataBodyRange.Value = .ListColumns("Kode").DataBodyRange.Value
.Range.Sort key1:="Kode", order1:=xlDescending, Header:=xlYes
.ListColumns("Unik").DataBodyRange.FormulaR1C1 = "=IF(RC[-1]<>R[-1]C[-1],1,0)*[Visi]"
.ListColumns("unik").DataBodyRange.Value = .ListColumns("unik").DataBodyRange.Value
End With

With pt
.PivotCache.Refresh
.PivotFields(" Unik").NumberFormat = "#"
.DataBodyRange.Font.Size = Range("a1").Font.Size
.DataBodyRange.Font.ColorIndex = xlAutomatic
End With

pt.PivotFields(" Unik").NumberFormat = "#,##0"
On Error Resume Next
Range("f1").Select
For rf = 1 To pt.RowFields.Count
If pt.RowFields(rf).Name <> "Data" And pt.RowFields(rf).Position <> pt.RowFields.Count Then
str2 = pt.RowFields(rf).Name & "[All;Total] ' Unik'"
pt.PivotSelect str2, xlDataOnly, True
Selection.NumberFormat = """"""
End If
Next

For rf = 1 To pt.ColumnFields.Count
If pt.ColumnFields(rf).Name <> "Data" And pt.ColumnFields(rf).Position <> pt.ColumnFields.Count Then
str2 = pt.ColumnFields(rf).Name & "[All;Total] ' Unik'"
pt.PivotSelect str2, xlDataOnly, True
Selection.NumberFormat = """"""
End If
Next

If pt.RowFields.Count > 0 Then
pt.PivotSelect "' Unik' 'Column Grand Total'", xlDataOnly, True
Selection.NumberFormat = """"""
End If

If pt.ColumnFields.Count > 0 Then
pt.PivotSelect "' Unik' 'Row Grand Total'", xlDataOnly, True
Selection.NumberFormat = """"""
End If

On Error GoTo 0
Range("c1").Select
Application.EnableEvents = True

End Sub