DataPoint Top and Left for 2007 or earlier.

Over at Datalabel height and width for 2007 or earlier Andy Pope says:

Another couple of properties that are not available prior to 2010 are the Left and Top values of the data point. If you want to know the position of the data point you need to get creative. Having determined the width and height of the data label you can then position the label left/right and above/below and calculate the data point.

Then Jon Peltier says:

Don’t spoil your afternoon moving datalabels around. If it’s an XY chart, then a little algebra goes a long way:
Horiz Position = plotarea.insideleft + plotarea.insidewidth*(X – Xmin)/(Xmax-Xmin)
Vert Position = plotarea.insidetop + plotarea.insideheight*(Ymax-Y)/(Ymax-Ymin)
… with corrections for plotting an axis in reverse order.

If it’s a line chart, the vertical position is as above, the horizontal position uses category number, total number of categories, and a correction for whether the axis crosses on or between categories.

If it’s a bar or column chart, you can get the length of the bar using the above (vert or horiz for column or bar chart), and if it’s stacked you need to sum them up appropriately. The width needs to take into account gap width, and if it’s clustered, how many series there are across each category.

All those potential Select Case statements that Jon will have to use give me the heebie-jeebies. So while I keenly await his forthcoming blog post on how to do things properly, I spent my afternoon being quick and dirty:

Function Pre2010_Position(dl As DataLabel) As String
Dim ptTop As Long
Dim ptLeft As Long
Dim dlLeft As Long
Dim dlTop As Long
Dim dlHeight As Long
Dim dlWidth As Long
Const lngPadding = 7

With dl
    dlTop = .Top
    dlLeft = .Left
    'Determine DL width and height
    dl.Left = ActiveChart.ChartArea.Width
    dlWidth = ActiveChart.ChartArea.Width - dl.Left
    dl.Top = ActiveChart.ChartArea.Height
    dlHeight = ActiveChart.ChartArea.Height - dl.Top
    dl.Position = xlLabelPositionRight
    If dl.Left + dlWidth = ActiveChart.ChartArea.Left + ActiveChart.ChartArea.Width Then
        'Datalabel is too wide to fit between point and plot edge
        dl.Position = xlLabelPositionLeft
        ptLeft = dl.Left + dlWidth + lngPadding
        ptLeft = dl.Left - lngPadding
    End If
    dl.Position = xlLabelPositionBelow
    ptTop = dl.Top - lngPadding
    dl.Position = xlLabelPositionAbove
    If dl.Top + dlHeight + lngPadding > ptTop Then ptTop = dl.Top + dlHeight + lngPadding
    'Return DataLabel to original position
    .Top = dlTop
    .Left = dlLeft
End With
Pre2010_Position = dlWidth & "|" & dlHeight & "|" & ptLeft & "|" & ptTop

End Function

To test this, just select a DataLabel and run this:

Sub test()
Dim strPosition As String
Dim dl As DataLabel
Set dl = Selection

strPosition = Pre2010_Position(dl)

Debug.Print "dlWidth: " & Split(strPosition, "|")(0)
Debug.Print "dlHeight: " & Split(strPosition, "|")(1)
Debug.Print "ptLeft: " & Split(strPosition, "|")(2)
Debug.Print "ptTop: " & Split(strPosition, "|")(3)

End Sub

Note that I’ve got a couple of DoEvents in the Pre2010_Position routine. Without them, on my 2013 install it just doesn’t seem to work properly unless you step through the code one line at a time. Tedious, and annoying because you can see everything moving on the graph. But unavoidable, it seems. And tracking this down was what took the most time. Very frustrating.

For instance, without the DoEvents I get this:
dlWidth: 102
dlHeight: 51
ptLeft: 83
ptTop: 97

…whereas with them, I get this:
dlWidth: 102
dlHeight: 51
ptLeft: 83
ptTop: 64

Here’s my revamped LeaderLines file. Anyone with 2007 or earlier fancy taking this for a spin, and advising if it works?

Datalabel height and width for 2007 or earlier.

Over at Chart LeaderLines in Excel 2010 or earlier I posted some code that draws leader-lines on charts just like Excel 2013 does.

Unfortunately that title was misleading in regards to the or earlier bit: Eric said that the code isn’t working at all in XL07, and Jon Acampora advised that the DataLabel.Height and DataLabel.Width properties are not available in XL07.

Andy Pope had a crafty workaround for this:

The trick to getting datalabel width and height is to force the data label off of the chart by setting left and top to chartarea width and height. The data labels will not actually go out of the chart so by reading the new left and top properties you can calculate the differences.

So I whipped up some functions to get the datalabel height and width:

Function dlHeight_2010(dl As DataLabel)
    dlHeight_2010 = dl.Height
End Function

Function dlWidth_2010(dl As DataLabel)
    dlWidth_2010 = dl.Width
End Function

Function dlHeight_Pre2010(dl As DataLabel)
    Dim dlTop As Long
    dlTop = dl.Top
    dl.Top = ActiveChart.ChartArea.Height
    dlHeight_Pre2010 = dl.Top - ActiveChart.ChartArea.Top
    dl.Top = dlTop
End Function

Function dlwidth_Pre2010(dl As DataLabel)
Dim dlleft As Long
    dlleft = dl.Left
    dl.Left = ActiveChart.ChartArea.Width
    dlwidth_Pre2010 = dl.Left - ActiveChart.ChartArea.Left
    dl.Left = dlleft
End Function

They are all separate functions because if I lumped them together in one, it wouldn’t compile on pre-2010 machines. So I call these from the main code with this:

If Application.Version = 14 Then
  dlHeight_2010 dl
  dlWidth_2010 dl

ElseIf Application.Version < 14 Then
    dlHeight_Pre2010 dl
    dlwidth_Pre2010 dl
End If

I’ve updated my leaderlines code to use these. If I comment out the stuff relating to 2010 and force Excel to use the pre2010 functions then it seems to work perfectly. But I asked a buddy to try it in his 2007 installation, and he advises that it doesn’t work…it just deletes the chart leader lines without redrawing them.

Anyone with 2007 or earlier fancy taking this for a spin, and advising where I might have gone off the rails?

Mucho Gracious.
Leader lines_20140225 v7

Data Validation doesn’t care about volatility.

Huh. All these years I’ve been telling people to avoid volatile functions in models – especially in dropdowns because large chains of dependents usually hang off of these – and it turns out that I’m wrong in that specific case, as per Roberto’s comment in this thread.

If you use a volatile function to feed data validation, then the formulas downstream of that data validation cell only get recalculated when you select something new from the dropdown. That is, it behaves just like a non volatile function.

Goodbye clunky INDEX-based cascading dropdowns. Hello INDIRECT and OFFSET-driven cascading dropdowns.

Opening the Addin Dialog like a Pro

Back in the old days when Excel had menus and toolbars, a guy could use Alt+t+i to open the Addins dialog (Tools – Addins). But that would only work if there was an open workbook. No open workbook, no dialog. Now in the days of the Ribbon, the shortcut is Alt+f+t a a Alt+g (File – Options – Addins – Go). You don’t need to have a workbook open, which is nice, but there is a bit of delay between the two “a’s” in the keyboard sequence.

MS did a wonderful thing when they made the old 2003 menu navigation still work in later versions. Even though there’s no longer a Tools menu, you can still use Alt+t+i to open the dialog. Unfortunately you still need to have a workbook open for it to work. I can’t imagine why that is, but it is.

Well, it’s VBA to the rescue. You can show most any dialog with Applicaiton.Dialogs().Show. But showing the Addins dialog returns an error if there is not an active workbook, just like with the old menus. It’s trivial enough to fix, to wit:

Sub ShowAddinDialog()
    Dim wb As Workbook
    'Dialog won’t show if there’s no workbook showing
    If ActiveWorkbook Is Nothing Then
        Set wb = Workbooks.Add
    End If
    'Show addin dialog
    'Close wb if it was created
    On Error Resume Next
        wb.Close False
End Sub

That creates a new workbook if needed, then shows the dialog. It keeps track of whether it created a workbook and, if so, closes it without saving. Hardly worth your time to read this post, you say? You already knew about this, you say? Here’s the real magic. Those old 2003 commandbars still lurk behind the scenes in Excel. If you create new ones, they show up on the Add-ins tab. But you can modify the existing one too. I put this little gem in the Auto_Open macro in the same workbook as my ShowAddinDialog procedure.

With Application.CommandBars(1).Controls("Tools").Controls.Add(msoControlButton, , , 1)
    .Caption = "&I"
    .OnAction = "ShowAddinDialog"
End With

And then to clean it up in Auto_Close.

On Error Resume Next

Commandbars(1) is the menu and Controls(“Tools”) is the Tools menu. I add a new control to position 1 on that Tools menu. I don’t need a fancy caption because I can’t see it anyway. I just need a caption with I as the hotkey. Whichever letter follows the ampersand (&) is the hotkey. The built-in addins menu item has a caption of Add-&Ins... making I the hotkey for it. But mine is higher up, so it wins.

In the previous post I referenced above, I add this macro to the QAT. But the muscle memory of Alt+t+i dies hard. Rather than retrain myself like a normal person, I’m embracing my quirks. I can now use Alt+t+i and get the desired results.

Creating an Appointment in Outlook 2010 Installation

Creating an Appointment in Outlook 2010
Creating an Appointment in Outlook 2010 Part II

You can download

Here are the steps to install the code.

  1. Download the zip file from the link above
  2. Unzip the four files and make a note of where they are
  3. Open Outlook 2010
  4. Press Alt+F11 to open the VBE
  5. Press Ctrl+R to show the Project Explorer

    Yours will no doubt look different than mine, but you should have a project called VbaProject.OTM.

  6. Right click anywhere in that project and choose Import File…
  7. Import the two .bas files and the one .frm file (you have to do them all separately)

  8. Edit (thanks Steffan): Choose Tools – References from the menu and add a reference to Microsoft VBScript Regular Expressions 5.5
  9. Choose Debug – Compile from the VBE menu
  10. Choose File – Save VbaProject.OTM from the VBE menu
  11. Close the VBE
  12. Right click on the Ribbon and choose Customize Quick Access Toolbar
  13. Choose Macros from the Choose commands from: dropdown
  14. Add MakeGoogleAppointment to the Customize Quick Access Toolbar listbox

  15. Press Alt+4 to open the form. My icon is fourth on the QAT so Alt+4 will run the macro. Yours may be in a different spot, so use the number for your situation. If you just press Alt, you’ll see the numbers on the QAT.
  16. Create an appointment

  17. Click OK

  18. And you’re done.

Important: Don’t forget this is mostly untested. Install at your own risk. And let me know what doesn’t work.

Creating an Appointment in Outlook 2010 Part II

Yesterday I posted about replicating how you can enter an item on Google’s calendar in Outlook. Today, we’ll look behind the form to see what’s going on. I won’t cover every piece of code, but you can download the code to see all of it. Let’s start with the Initialize event. In the entry point procedure, I set the When property in certain situations. In the Initialize method, I populate the narrative textbox if When already has a value.

Public Sub Initialize()
    If Me.When <> 0 Then
        Me.tbxNarrative.Text = Format(Me.When, "h:mm am/pm") & Space(1)
    End If
End Sub

If the user has already made some sort of selection on a calendar, this saves having to type it. Changing the narrative textbox also fires an event that is the bulk of the code in the form. Let’s take a look at that now.

Private Sub tbxNarrative_Change()
    Dim rxNarrative As VBScript_RegExp_55.RegExp
    Dim rxMatches As VBScript_RegExp_55.MatchCollection
    Dim dtTimeEntered As Date
    Dim sMeridian As String
    Set rxNarrative = New VBScript_RegExp_55.RegExp
    rxNarrative.Pattern = RegExPattern
    rxNarrative.IgnoreCase = True
    If rxNarrative.test(Me.tbxNarrative.Text) Then
        Set rxMatches = rxNarrative.Execute(Me.tbxNarrative.Text)
        With rxMatches.Item(0) 'there's only one match, all the capture groups are submatches of it
            'Get AM or PM
            sMeridian = GetAMPM(.SubMatches(0), .SubMatches(1))
            dtTimeEntered = ConvertStringToTime(.SubMatches(0), sMeridian)
            'Account for time zones
            Me.When = Me.Day + ConvertTimeToLocal(dtTimeEntered, .SubMatches(2))
            Me.What = .SubMatches(3)
            'Default to 1 hour duration if not entered
            If Len(.SubMatches(5)) > 0 Then
                Me.Duration = Val(.SubMatches(5))
                Me.Duration = 1 'hour
            End If
            If Len(.SubMatches(4)) > 0 Then
                Me.Location = .SubMatches(4)
            End If
        End With
        Me.tbxNarrative.BackColor = vbWhite
        Me.tbxNarrative.BackColor = vbYellow 'visual indicator that narrative doesn't work
    End If
    'Show the results
End Sub

You need to set a reference to the VBScript Regular Expressions 5.5 library. I put the regex pattern in a separate, private function to keep the code tidy. I’ll show that below. If the regex passes, I call Execute to get the matches, then use the Submatches to populate my form’s properties. I get either AM or PM via another function. Then I use that and yet another function to convert the time the user entered into a Date data type. That date gets converted based to the user’s local time. The Duration property is set to 1 hour if the user doesn’t enter a duration. The submatches are in this order

  1. The time, like 3 or 3:00
  2. Either AM, PM, or an empty string if the user didn’t specify
  3. The time zone – EST, EDT, CST, CDT, MST, MDT, PST, PDT, or an empty string if not specified. Definitely could increase these options at some point.
  4. The subject – text that follows the time and precedes either location or duration
  5. The location – text that follows space+at+space
  6. The duration = n.n hour(s) that follows space+for+space

To get AM or PM, I wrote a separate function that takes the time as a string and whatever the user entered for AM or PM if any. If the user entered AM or PM, that’s what’s returned. If not, I assume the time is between 7AM and 6PM.

Private Function GetAMPM(ByVal sTime As String, ByVal sAmpm As String) As String
    Dim sReturn As String
    Dim dtTime As Date
    If Len(sAmpm) > 0 Then
        sReturn = sAmpm
        dtTime = ConvertStringToTime(sTime, "AM")
        If dtTime >= TimeSerial(7, 0, 0) And dtTime < TimeSerial(12, 0, 0) Then
            sReturn = "AM"
            sReturn = "PM"
        End If
    End If
    GetAMPM = sReturn
End Function

This is a little goofy because it checks the time before any time zone shift. I considered applying the time zone shift first, and probably should have, but I didn’t want to rewrite the time zone stuff, so I didn’t. Maybe I’ll fix that in the next version.

The GetAMPM function and the event procedure both use ConvertStringToTime, shown below. It uses the VBA.TimeValue function. TimeValue doesn’t work with a single digit, so I append the “:00″ if there’s not already a colon in there. I also tack on the meridian. When I call it from GetAMPM, I always use AM because I don’t know the meridian yet.

Private Function ConvertStringToTime(sTime As String, sMeridian As String) As Date
    If InStr(1, sTime, ":") = 0 Then
        ConvertStringToTime = TimeValue(sTime & ":00" & Space(1) & sMeridian)
        ConvertStringToTime = TimeValue(sTime & Space(1) & sMeridian)
    End If
End Function

Once I have the meridian, I recall ConvertStringToTime with the proper value and store that in dtTimeEntered – this is what the user entered converted to a Date data type. The next step is to account for any time zone information entered by the user. I call ConverTimeToLocal, which uses a Windows API to get the users time zone. I got the time zone API from Chip’s site.

Public Function ConvertTimeToLocal(ByVal dtTime As Date, ByVal sZone As String) As Date
    Dim tz As TIME_ZONE
    Dim lGmtOff As Long
    tz = GetTimeZoneInformation(tzi)
    Select Case sZone
        Case "EDT"
            lGmtOff = -4
        Case "EST", "CDT"
            lGmtOff = -5
        Case "CST", "MDT"
            lGmtOff = -6
        Case "MST", "PDT"
            lGmtOff = -7
        Case "PST"
            lGmtOff = -8
        Case vbNullString
            lGmtOff = -tzi.Bias / 60
    End Select
    ConvertTimeToLocal = dtTime - (TimeSerial(0, tzi.Bias, 0) + TimeSerial(lGmtOff, 0, 0))
End Function

This basically converts the time to GMT, then to the users time. If the user didn’t enter a time zone, Case vbNullString, the Bias (in minutes) is added and subtracted leaving the original time.

Everything else in the event procedure is just jamming submatches into properties. I turn the textbox backcolor yellow if the user enters something that the regex can’t decipher. At the end of the procedure, all those properties I filled are displayed in a listbox with a call to UpdateListBox.

Private Sub UpdateListbox()
    Me.lbxAppointment.AddItem "What: " & Me.What
    Me.lbxAppointment.AddItem "Where: " & Me.Location
    Me.lbxAppointment.AddItem "Starts at: " & Format(Me.When, "m/d/yyyy hh:mm")
    Me.lbxAppointment.AddItem "Ends at: " & Format(Me.EndTime, "m/d/yyyy hh:mm")
End Sub

I created a separate EndTime property that adds the duration to the start time. The duration can be an integer or a decimal and I split that out in a VBA.TimerSerial function. That makes me better than Google.

Public Property Get EndTime() As Date
    EndTime = Me.When + TimeSerial(Int(Me.Duration), (Me.Duration - Int(Me.Duration)) * 60, 0)
End Property

As promised, here’s the function that holds the regex pattern. I split it out into an array so I could hopefully understand it six months from now.

Private Function RegExPattern() As String
    Dim aPattern(1 To 11) As String
    aPattern(1) = "^((?:1[0-2]|0?[1-9])(?::[0-5]\d)?)" 'time
    aPattern(2) = "\s*" 'optional white space
    aPattern(3) = "([ap]m)?" 'optional ampm
    aPattern(4) = "\s*"
    aPattern(5) = "([ECMP][DS]T)?" 'optional time zone
    aPattern(6) = "\s*"
    aPattern(7) = "(.*?" 'what
    aPattern(8) = "(?=\s+for\s+|\s+at\s+|$))" 'look ahead for ' for ' or ' at '
    aPattern(9) = "(?:\s+at\s+(.*?" 'where
    aPattern(10) = "(?=\s+for\s+|$)))?" 'look ahead for ' for '
    aPattern(11) = "(?:\s+for\s+(\d*(?:\.\d+)?)\s*hour)?" 'duration
    RegExPattern = Join(aPattern, vbNullString)
End Function

That’s probably enough code for one post. What you don’t see, but you can download, is the property getters and setters for UserCancel, Location, When, What, Duration, and Day. There’s also code for clicking OK and Cancel, which simply sets the UserCancel property and hides the form.

You can download

Tomorrow I’ll post a couple of notes and some installation instructions if you want to give it a try.

Creating an Appointment in Outlook 2010

I got a new job about a year ago and I went from using Google’s calendar to Outlook. I’ve added some code to Outlook to handle emails a little more like GMail does, but one thing I’ve missed is the ability to add something to the calendar easily. According to Google, you can enter multiple properties of the appointment in one string like “7pm Dinner at Pancho’s” and it’s awesome.

It’s not perfect, though, so I didn’t want to just replicate the function, I wanted to improve it. For one, Google doesn’t deal with fractions of hours very well. Now I can type a narrative in a textbox and create an appointment.

And that opens a pre-filled appointment like this

I started trying to parse the text with a lot of Split() functions, but it quickly became cumbersome. Not impossible, just not very elegant. To be more fancy, I ignored this advice:

Some people, when confronted with a problem, think
“I know, I’ll use regular expressions.” Now they have two problems.

To be perfectly honest, nobody ever confused me with someone who could write regular expressions beyond the incredibly simple ones. But I gave it a go and eventually got some help from stackoverflow and from Rick Measham.

The rules go like this:

  • Start with a time. Can be 5, 5:00, 5pm, 5:00pm, 5 pm, 5 pm CST, 5pmPST and a bunch of other stuff
  • Then the subject or title of the appointment. Stop capturing when you get to " for " or " at " because those are keywords indicating other information.
  • If you get to " at ", everything after that is the location. Stop capturing when you get to " for ".
  • If you get to " for ", everything after that is the duration in hours.

The regex looks like this:


Simple, huh? I’ll wrap up this post with a discussion of the entry point procedure. Tomorrow, I’ll discuss the code behind the form.

Public Sub MakeGoogleAppointment()
    Dim dtStart As Date
    Dim dtDay As Date
    Dim ufGoogle As UGoogle
    Dim ai As AppointmentItem
    'if the user is on a calendar, get the date and/or time
    On Error Resume Next
        dtDay = Int(Application.ActiveExplorer.CurrentView.SelectedStartTime)
        dtStart = Application.ActiveExplorer.CurrentView.SelectedStartTime - dtDay
    On Error GoTo 0
    'if their not on a calendar, assume today
    If dtDay = 0 Then
        dtDay = Date
    End If
    'Get the rest of the string via a form
    Set ufGoogle = New UGoogle
    ufGoogle.Day = dtDay
    ufGoogle.When = dtStart
    'create the new appointment
    If Not ufGoogle.UserCancel Then
        Set ai = Application.CreateItem(olAppointmentItem)
        ai.Start = ufGoogle.When
        ai.Duration = ufGoogle.Duration * 60
        ai.Subject = ufGoogle.What
        ai.Location = ufGoogle.Location
    End If
End Sub

The first section attempts to get whatever is selected if the user is looking at a calendar. The SelectedStartTime property returns a Date. It’s only the date portion if the user is on Month view (pretty much the only view I use). It includes both the date and time if the user is on a view that has times. The Int() function gets only the date by lopping off the time if it exists.

If the date is zero, then the user isn’t on a calendar view and I set the date to today.

Next, I instantiate a new userform, pass in some data via Property Let procedures, and run some setup code in an Initialize method.

Finally, if the user doesn’t click Cancel, a new AppointmentItem is created. The duration in my narrative is in hours, but Outlook’s Duration is in minutes, so I multiply by 60 to convert it. The new AppointmentItem is displayed for the user to add more information of change things.

The Amsterdam Excel Summit

The Amsterdam Excel Summit

A Unique Opportunity

Dear Excel lovers,

Is Excel the first and last application you use every day?
Do you want to improve your Excel skills and get first-hand knowledge from the absolute best Excel experts in the world?
Then this unique event is for you.

The Amsterdam Excel Summit

Worldclass Excel Experts

An absolute unique group of Excel MVP’s will gather in Amsterdam to share their expert knowledge with you. The Excel MVP’s happen to be in Amsterdam for a meeting and we’ve succeeded in getting some of them to present at our event. There is not much chance on this happening again anytime soon, so make sure you register!

Jan Karel Pieterse

Applying NumberFormat Version 4

I’ve been using a macro to apply the comma style for about five years. I’ve even enhanced it. It’s such a simple bit of code that it really never broke – until now. I got a workbook that caused the code to fail because it didn’t have a style named ‘Comma’. I just assumed that style was built in to all workbooks.

I received a workbook in 2003 format (.xls). I Saved As to 2010 format (.xlsx) because that’s what I always do. I even closed and re-opened it because I don’t like it when it says ‘Compatibility Mode’ in the title. Here’s what the Styles gallery looks like compared to the Styles gallery on a new workbook below.

OK, somebody deleted the number format styles. Seems strange, but I’ve seen stranger. Then more strangeness occurred. None of the cells on this unprotected worksheet were locked. And when I add a new worksheet to the workbook, every cell on the new worksheet was unlocked. I don’t recall ever seeing that before. Generally, every cell on a new worksheet is locked and the sheet is unprotected. That way when you protect a worksheet, you get expected behavior.

I still don’t understand why this workbook behaves the way it does, but I do need to change my code to account for it. I toyed with the idea of adding a Comma style if it didn’t exist, but the Comma style is just a number format, so I didn’t see any downside to just applying a number format instead of a style. Also, I’ve thoroughly enjoyed my new toggle feature for PivotItems that switches between zero and two decimal places and applied that same logic to cells.

Sub MakeComma()
    Dim pf As PivotField
    Const sONEDECIMAL As String = "#,##0"
    Const sTWODECIMALS As String = "#,##0.00"
    Const sCOMMAONE As String = "_(* #,##0_);_(* (#,##0);_(* ""-""_);_(@_)"
    Const sCOMMATWO As String = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""??_);_(@_)"
    gclsAppEvents.AddLog "^m", "MakeComma"
    If TypeName(Selection) = "Range" Then
        On Error Resume Next
            Set pf = ActiveCell.PivotField
        On Error GoTo 0
        If pf Is Nothing Then
            If Selection.NumberFormat = sCOMMATWO Then
                Selection.NumberFormat = sCOMMAONE
                Selection.NumberFormat = sCOMMATWO
            End If
            If pf.NumberFormat = sTWODECIMALS Then
                pf.NumberFormat = sONEDECIMAL
                pf.NumberFormat = sTWODECIMALS
            End If
        End If
    End If
End Sub

Instant Pivot: Just Add Water



Sub InstantPivot()

'   InstantPivot: Just Add Water
'   Assign this to Ctrl + Shift + P or something like that.

'   Description:    * Turns selection into Excel ListObject
'                   * Makes a Pivottable out of it at the edge of the used range
'                   * Applies my preferred default settings
'                   * Selects the Pivot and cuts it, so that
'                     Dick Kusleika can then use arrow keys
'                     and Control + V to paste it where he wants
'                     without having to touch that unclean dusty rodent
'                     he keeps at the edge of his Desk.Usedrange

'Here's the settings it applies.
'   1.  Changes the Report Layout to "Show in Tabular Form"
'   2.  Turns on  "Repeat All Item Labels" option
'   3.  Turn off Subtotals
'   4.  Turn off Grand Totals
'   5.  De-selects the Row Headers option from the Design tab.
'   6.  Turns off 'Autofit Column Width on Update'
'   7.  Turns off 'Save Source Data with file' option.
'   6.  Adopts the source formatting

'   Programmer:     Jeff Weir
'   Contact: or

'   Name/Version:   Date:       Ini:   Modification:
'   InstantPivot    20140213    JSW     Initial programming
'   InstantPivotV2  20140216    JSW     Added error handler and check for multiple cells
'   InstantPivotV3  20140216    JSW     Adopted SNB's approach of setting numberformat while turning subtotals off
'   InstantPivotV4  20140216    JSW     If run on existing pivot that is not based on ListObject, turns source into ListObject
'   InstantPivotV5  20140216    JSW     Now ignores Values fields and doesn't apply format if pf.function = xlCount
'   InstantPivotV6  20140324    JSW     Had accidentally left out With Application stuff at the start

'   Inputs:         None

'   Outputs:        PivotTable is formatted accordingly

    Dim pc As PivotCache
    Dim pf As PivotField
    Dim pt As PivotTable
    Dim lo As ListObject
    Dim rng As Range
    Dim strLabel As String
    Dim strFormat As String
    Dim i As Long
    Dim wksSource As Worksheet
   With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlManual
    End With
    On Error Resume Next
    Set pt = ActiveCell.PivotTable
    On Error GoTo errhandler
    If pt Is Nothing Then
        Set lo = ActiveCell.ListObject
        If lo Is Nothing Then Set lo = ActiveSheet.ListObjects.Add(xlSrcRange, Selection.CurrentRegion, , xlYes)
        Set rng = Cells(ActiveSheet.UsedRange.Row, ActiveSheet.UsedRange.Columns.Count + ActiveSheet.UsedRange.Column + 1)
        Set pc = ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=lo)
        Set pt = pc.CreatePivotTable(TableDestination:=rng)
        'Check if pt is based on a ListObject.
        '  *  If so, set lo equal to that ListObject
        '  *  If not, turn that source data into a ListObject
        On Error Resume Next
        Set lo = Range(pt.SourceData).ListObject
        On Error GoTo errhandler
        If lo Is Nothing Then
            Set rng = Application.Evaluate(Application.ConvertFormula(pt.SourceData, xlR1C1, xlA1))
            Set wksSource = rng.Parent
            Set lo = wksSource.ListObjects.Add(xlSrcRange, rng, , xlYes)
            pt.ChangePivotCache ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=lo.Name)
        End If

    End If

    With pt
        .ColumnGrand = False
        .RowGrand = False
        .RowAxisLayout xlTabularRow
        .RepeatAllLabels xlRepeatLabels
        .ShowTableStyleRowHeaders = False
        .ShowDrillIndicators = False
        .HasAutoFormat = False
        .SaveData = False
        .ManualUpdate = True
        If ActiveCell.CurrentRegion.Cells.Count > 1 Then
            For i = 1 To .PivotFields.Count - .DataFields.Count 'The .DataField.Count bit is just in case the pivot already exists
                Set pf = .PivotFields(i)
                With pf
                    If pf.Name <> "Values" Then
                        .Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
                        On Error Resume Next
                        .NumberFormat = lo.DataBodyRange.Cells(1, i).NumberFormat
                        On Error GoTo errhandler
                    End If
                End With
            Next i
        End If
    End With
    ' Get DataFields to match the formatting of the source field
    ' Note that this will only be neccessariy in the case that we're
    ' running this code on an existing pivot
    On Error GoTo errhandler
    If pt.DataFields.Count > 0 Then
        For Each pf In pt.DataFields
            If pf.Function <> xlCount Then pf.NumberFormat = pt.PivotFields(pf.SourceName).NumberFormat
            ' Do away with 'Sum of' or 'Count of' prefix etc if possible
            On Error Resume Next
            pf.Caption = pf.SourceName & " "
            On Error GoTo errhandler
        Next pf
    End If

    'This needs to go before the .Cut bit, otherwise the .Cut stack gets wiped
     With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlAutomatic
    End With
    With pt
        .ManualUpdate = False
    End With
        If Err.Number > 0 Then
            With Application
                .ScreenUpdating = True
                .EnableEvents = True
                .Calculation = xlAutomatic
            End With
            MsgBox "Whoops, there was an error: Error#" & Err.Number & vbCrLf & Err.Description _
                     , vbCritical, "Error", Err.HelpFile, Err.HelpContext
        End If
End Sub

Begone, Carpal Tunnel Syndrome.