VBA Archives - Page 6 of 8

Conditional Formatting Color Scales Based on Other Cells

Posted on January 23, 2013 by Doug Glancy

With formula-based conditional formatting, it’s pretty easy to base the formats on other cells in the workbook, simply by referring to those cells in the formula. However, it’s more complicated if you want color scales derived from values in another range. In this post I discuss two ways to base color scales on another range. The first uses the camera tool while the second is a VBA subroutine that mimics conditional formatting.

Below is an example of what I’m talking about. The color formatting isn’t based on the values in the pivot table. Instead, it reflects the values in the second table, each cell of which contains the difference from the previous year in the pivot table. The colors range from red at the low end to green at the high end:

ormat with camera tool 1

So, here’s my two approaches to doing this:

Using the Camera Tool

This method uses Excel’s under-publicized camera tool, which creates a live picture linked to a group of cells. In this case the formatting is applied to a pivot table, but you can do it with any range. Here’s the steps:

Create the range of formulas that you’ll base the conditional formatting on.
Format the numbers in that range to be invisible, by using a custom format of “;;;”. All you want to see is the conditional formatting.
Use the camera tool to take a picture of the entire pivot table and paste it over the range you just created, lining up the conditionally formatted cells. Set the picture to be completely transparent, using the “no fill” setting. This way you can see through the picture to the conditionally formatted cells underneath.

The result will be like the illustration below. The source pivot table is in rows 11 to 18, and you can see that the picture starting in row 2 is linked to it. The cells underneath the picture contain the formulas referring to the pivot table. The conditional formatting is based on these cells, whose text is invisible because of the custom format.

format with camera tool 2

One thing to be aware of is that the picture doesn’t update until there’s a worksheet recalculation. You may have to force recalculation with F9 to have the picture update.

For one project I augmented this method by writing code that let me toggle back and forth between the values in the pivot table and the values the conditional formatting is based on.

Using VBA to Create “FauxMatting”

As the heading implies, this method attempts to replicate conditional formatting using VBA. The following subroutine takes two ranges – a source and a target range – as its arguments. It finds the highest and lowest values in the source range. It assigns each of those values a color in a scale from green to red, with white in the middle. This is done by dividing the range of values source values into 255 increments. The colors are then assigned to the target range:

Sub ConditionalFauxmatting(rngSource As Excel.Range, rngTarget As Excel.Range)
Const NUMBER_OF_INCREMENTS As Long = 255
Dim MinValue As Double
Dim MaxValue As Double
Dim ScaleIncrement As Double
Dim ScalePosition As Long
Dim var As Variant
Dim CellColor() As Long
Dim i As Long, j As Long

If Not (rngSource.Rows.Count = rngTarget.Rows.Count And rngSource.Columns.Count = rngTarget.Columns.Count) Then
MsgBox "Source and Target ranges must be" & vbCrLf & "same shape and size"
GoTo exit_point
End If
MinValue = Application.WorksheetFunction.Min(rngSource.Value)
MaxValue = Application.WorksheetFunction.Max(rngSource.Value)
'divide the range between Min and Max values into 255 increments
ScaleIncrement = (MaxValue - MinValue) / NUMBER_OF_INCREMENTS
'if all source cells have the same value or there's only one
If ScaleIncrement = 0 Or rngSource.Cells.Count = 1 Then
rngTarget.Cells.Interior.Color = RGB(255, 255, 255)
GoTo exit_point
End If
'assign all the values to variant array
var = rngSource.Value
ReDim CellColor(UBound(var, 1), UBound(var, 2))
For i = LBound(var, 1) To UBound(var, 1)
For j = LBound(var, 2) To UBound(var, 2)
'the scale position must be a value between 0 and 255
ScalePosition = (var(i, j) - MinValue) * (1 / ScaleIncrement)
'this formula goes from blue to red, hitting white - RGB(255,255,255) at the midpoint
CellColor(i, j) = RGB(Application.WorksheetFunction.Min(ScalePosition * 2, 255), _
IIf(ScalePosition < 127, 255, Abs(ScalePosition - 255) * 2), _
IIf(ScalePosition < 127, ScalePosition * 2, Abs(ScalePosition - 255) * 2))
Next j
Next i
'assign the colors stored in the array
'to the target range
With rngTarget
For i = 1 To .Rows.Count
For j = 1 To .Columns.Count
.Cells(i, j).Interior.Color = CellColor(i, j)
Next j
Next i
End With

exit_point:
End Sub

The result looks like this:

format with VBA

I’m not sure how practical this is, but it was fun to figure out! Obviously, you’d want to tie this to a worksheet or pivot table event to update the formatting when the values change.

Here’s a workbook demonstrating these two methods.

Hide Pivot Table Single-Item Subtotals

Posted on November 28, 2012 by Doug Glancy

This pivot table looks awkward. The countries without provinces have a lone detail line, followed by a subtotal line with the exact same information. You can fix this by collapsing the single-item rows one at a time, but that’s time-consuming, and boring. Wouldn’t it be much more fun to write some code to hide pivot table single-item subtotals?

A year or so ago I did just that. In reviewing it for this post I cleaned it up and learned a few things about where it works and where it doesn’t. When I run it the result looks like this, with the duplicated population counts nicely hidden:

The heart of the code is this simple routine. You pass it a single PivotField and it hides the details for any item in that field that contains just one row:

Sub ProcessPivotField(pvtField As Excel.PivotField)
Dim ptItem As Excel.PivotItem

For Each ptItem In pvtField.PivotItems
If ptItem.RecordCount > 1 Then
ptItem.ShowDetail = True
Else
ptItem.ShowDetail = False
End If
Next ptItem
End Sub

In my first version of this code I used ptItem.DataRange.Rows.Count. This caused errors with hidden items, because their DataRange is Nothing. With ptItem.RecordCount it just sails on through.

The main procedure checks whether the cursor is in a pivot table and a few things like that. It then calls a function that returns only the visible pivot table row and column fields:

Function GetPivotFieldNames(pvtTable As Excel.PivotTable) As String()
Dim PivotFieldNames() As String
Dim pvtField As Excel.PivotField
Dim i As Long
Dim PivotFieldsCount As Long

PivotFieldsCount = 0
With pvtTable
ReDim Preserve PivotFieldNames(1 To .PivotFields.Count)
For i = LBound(PivotFieldNames) To UBound(PivotFieldNames)
Set pvtField = .PivotFields(i)
If pvtField.Orientation = xlColumnField Or _
pvtField.Orientation = xlRowField Then
PivotFieldsCount = PivotFieldsCount + 1
PivotFieldNames(PivotFieldsCount) = pvtField.Name
End If
Next i
End With
ReDim Preserve PivotFieldNames(1 To PivotFieldsCount)
GetPivotFieldNames = PivotFieldNames
End Function

The returned pivot fields are passed to a userform not unlike this one, except that it allows you to pick multiple items. That way you can collapse more than one field at a time. (I don’t show the code here, but you can get it all from the download link at the end.)

The form looks like this:

Collapsing single-item rows works great for lists like this one of continents, countries and provinces, because if a country has no subdivisions there’s no further detail to show. It’s just Iceland.

Where it doesn’t make as much sense is with something like sales by year, month, week and date:

Even if you had sales in only one week in February, you’ll probably call it “week 6”, or “February 12 to 19”, or something. But when you collapse February that detail gets hidden.

Even more limiting is that you can’t collapse February for one year and leave it expanded for another. At least, I can’t find any way, either in VBA or in Excel. You either show a total for all your Februaries, or for none. In the example above it would be nice to hide the February 2012 total, but show it for 2013. If anybody knows a way to do that, please let us know.

To fool around with this for yourself you can download a workbook with a couple of sample pivots and the Single-Item Subtotal hider.

NOTE: I noticed a ways into this post that the population data is old. I tried to find something more recent, but didn’t come up with anything that had the provinces/states data. But it was nicely packaged in an Access database.

UserForm Event Handler Class – Multiple Controls

Posted on October 14, 2012 by Doug Glancy

Down through the ages, VBA programmers have asked, “Do I really need a click event handler for each button on my form, even if they all do the same thing?” The answer, of course, is “no.” You can use a class to create an array of event handlers for the controls. In this post, I’ll expand on that concept to groups of checkboxes that work together in a “group/member” relationship.

I’ve been working on a form with groups of checkboxes that perform pretty much the same action. All the checkboxes in a row are controlled by a “group” switch. Conversely, the group switch turns on or off, or goes to that grayed-out “Null” position, based on the state of its “member” checkboxes. Just like this worksheet header/footer preview form. In this case the group switches are the “Headers” and “Footers” checkboxes, with the member checkboxes to the right.

This form uses a collection of classes, one for each of the six member controls. Each class instance contains that single member control, along with a collection of all the member controls in the same row, and the row’s group checkbox. The class contains two event handlers: one for the member checkbox, and one for the group checkbox. To be able to create the event handlers, these two controls are declared using the WithEvents keyword.

The class looks like this:

'clsHeadFooterCheckboxes

Public WithEvents GroupCheckbox As MSForms.CheckBox
Public WithEvents MemberCheckbox As MSForms.CheckBox
Public collmemberCheckboxes As Collection
Public ParentForm As MSForms.UserForm

Private Sub MemberCheckbox_Click()
Dim ctl As MSForms.Control
Dim CheckedCheckboxCount As Long

'Avoid endless control click loops
If MemberCheckbox.Enabled Then
'count the number of checked "member" controls
For Each ctl In collMemberCheckboxes
If ctl = True Then
CheckedCheckboxCount = CheckedCheckboxCount + 1
End If
Next ctl

With GroupCheckbox
'Also avoid endless control click loops
.Enabled = False
'set the state of the group based on whether
'all, no, or some members are checked
.TripleState = False
Select Case CheckedCheckboxCount
Case 0
.Value = False
Case collmemberCheckboxes.Count
.Value = True
Case Else
.TripleState = True
.Value = Null
End Select
.Enabled = True
End With
End If
SetTextBoxVisibility

End Sub

Private Sub GroupCheckbox_Click()
Dim ctl As MSForms.Control

'turn members on or off depending on group state
With GroupCheckbox
'TripleState is only true when set by members
'We don't want it to be available when clicking group
.TripleState = False
For Each ctl In collmemberCheckboxes
'Avoid endless control click loops
ctl.Enabled = False
ctl.Value = .Value
ctl.Enabled = True
Next ctl
End With
SetTextBoxVisibility

End Sub

Sub SetTextBoxVisibility()
'Set the textboxes paired to the member controls visibility
ParentForm.Controls(Replace(memberCheckbox.Name, "chk", "txt")).Visible = memberCheckbox.Value
End Sub

While writing this code, I solved a problem that stumped me in the past: how to avoid looping of events when a pair of controls each triggers a change in the other. Application.EnableEvents doesn’t apply to userform controls, so you typically create some kind of EventsEnabled boolean variable. This is easy enough when only one control has a change event, but I’ve never been able to get it to work when two controls are affected by each other’s Change or Click events. This project was even more confusing, because events are triggered in three separate class instances, one for each member control in a row!

My solution was inspired by recent experience with VB.Net, where you can simply add and remove event handlers within your code. If you don’t want to trigger events, just unlink the control from its event handler, and add it back when you’re done. Obviously you can’t do that in VBA, but I realized I could disable a control before performing an action that would normally trigger its event. I did this in the MemberCheckbox_Click event. In the other direction it’s a little different. In the GroupCheckbox_Click event I disable the member checkbox and then check its state in the MemberCheckbox_Click event. This acts like an across-all-class-instances global variable that is tested in the groupCheckbox_Click event. I think. At any rate, it works.

Another tricky part was managing the group checkbox’s TripleState property. It only gets turned on in the MemberCheckbox_Click event, and only when some, but not all, of the member checkboxes are checked. This allows us to show a “grayed out” group checkbox. TripleState gets turned back off in the group checkbox’s click event, so when you are clicking it the only possibilities are checked or not checked.

This class is pretty flexible. You can add rows, or checkboxes within rows, and it works correctly. Just be sure to add the controls within the appropriate group and follow the naming pattern of the existing controls.

The userform code looks like this:

Private cHeadFooterCheckboxes As New clsHeadFooterCheckboxes
Private collCheckBoxClasses As Collection
Private WithEvents ThisBook As Excel.Workbook

Private Sub UserForm_Initialize()

Set ThisBook = ThisWorkbook
InitializeClasses
SetWorksheetCombo
SetDisplayTextBoxes
End Sub

Sub InitializeClasses()
Dim ctl As MSForms.Control
Dim RowName As String

Set collCheckBoxClasses = New Collection
'For each group control
For Each ctl In Me.grpgroupControls.Controls
RowName = Replace(ctl.Name, "chkAll", "")
InitializeRowClasses RowName
Next ctl
End Sub

Sub InitializeRowClasses(RowType As String)
Dim collRowmembers As Collection
Dim ctl As MSForms.Control

Set collRowmembers = New Collection
For Each ctl In Me.grpmemberControls.Controls
'If it's a checkbox in the row being processed
If InStr(ctl.Name, RowType) > 0 Then
collRowmembers.Add ctl, ctl.Name
End If
Next
'Create a class for each member control in the row
For Each ctl In collRowmembers
Set cHeadFooterCheckboxes = New clsHeadFooterCheckboxes
'initialize the class with the
'control, other members and group
With cHeadFooterCheckboxes
Set .memberCheckbox = ctl
Set .groupCheckbox = Me.Controls("chkAll" & RowType)
Set .collmemberCheckboxes = collRowmembers
Set .ParentForm = Me
End With
'add the class to the collection
collCheckBoxClasses.Add cHeadFooterCheckboxes
Next ctl
End Sub

End Sub

Private Sub cboWorksheets_Change()
If Me.cboWorksheets.Enabled Then
SetDisplayTextBoxes
End If
End Sub

Private Sub ThisBook_SheetActivate(ByVal Sh As Object)
SetWorksheetCombo
End Sub

There’s other code in the userform that handles the worksheet combobox. You can download a sample workbook to see it all in action.

Creating Dynamic Runtime Lists

Posted on September 30, 2012 by Doug Glancy

I work in a world of lists. Lists that need to be reported on. Often these lists are implicit, in that they’re contained in the data that’s being processed and I don’t know in advance what, or how many, items they contain. In these situations, I determine the list by extracting it from the data right before processing it. That’s what I mean by creating dynamic runtime lists.

I first stumbled upon this concept when creating my FaceIdViewer. It was unique in that instead of hard-coding the number of FaceIDs in different versions of Excel, it just counted them up at runtime. Something like this code, which still works in Excel 2010.

Sub CountFaceids()
Dim cbar As Office.CommandBar
Dim ctl As Office.CommandBarControl
Dim FaceIdNumber As Long
Dim NoMoreFaceIds As Boolean

'the cbar probably doesn't exist, but if it does let's delete it
On Error Resume Next
Application.CommandBars("TempForFaceiIdCount").Delete
On Error GoTo 0
Set cbar = Application.CommandBars.Add(Name:="TempForFaceiIdCount", temporary:=True)
With cbar
Set ctl = cbar.Controls.Add(Type:=msoControlButton)
'FaceId index is zero-based
FaceIdNumber = 0
Do Until NoMoreFaceIds
On Error Resume Next
'Loop through the FaceId numbers, assigning them to the button,
'until we error at the upper limit plus one
ctl.FaceId = FaceIdNumber
If Err.Number <> 0 Then
NoMoreFaceIds = True
End If
On Error GoTo 0
FaceIdNumber = FaceIdNumber + 1
Loop
End With
Application.CommandBars("TempForFaceiIdCount").Delete
MsgBox Format(FaceIdNumber, "#,##0") & " FaceIds found"
End Sub

(As an aside, it’s interesting that Excel 2010 has 22,716 FaceIds, more than double the 10,040 in Excel 2003, and thousands more than 2007, which has 16,210. I wonder why there’s such a big increase in something with such decreased use?)

Another example of creating lists on the fly is splitting worksheets into multiple ones, based on the values in a certain column. It can be really hard to know beforehand what values will be in the column, as in this example of an ice cream store with multiple salespeople and, of course, many delicious flavors.

In addition to getting a list of salespeople in column A to report on, I want the list to contain unique entries. Each salesperson should only be listed once.

To get this unique list I use something like the function below. It stores the list in a collection, taking advantage of the fact that collections can’t contain duplicate keys. The function takes a range and adds each cell’s value to the collection, provided the value is unique. We surround the attempt with On Error statements, so that the code continues merrily along if trying to add a duplicate value causes an error. In this example it will quietly error many more times than not, generating a list of about 10 salespeople from the dozens of rows containing their names.

Function GetUniqueCellValues(rng As Excel.Range) As Collection
Dim collUniqueCellValues As Collection
Dim CellArray As Variant
Dim i As Long, j As Long

'assign all the cell values to a variant array
CellArray = rng.Value
Set collUniqueCellValues = New Collection
'cycle through the two dimensions of the array
For i = LBound(CellArray, 1) To UBound(CellArray, 1)
For j = LBound(CellArray, 2) To UBound(CellArray, 2)
'if we try to add a duplicate, ignore the error
On Error Resume Next
collUniqueCellValues.Add CStr(CellArray(i, j)), CStr(CellArray(i, j))
On Error GoTo 0
Next j
Next i
Set GetUniqueCellValues = collUniqueCellValues
End Function

The code above could just cycle through each cell in the range. Instead it loads the range’s values into a variant array and processes that array, which greatly speeds things up with long lists.

Below is an ice cream sales report subroutine that uses this GetUniqueCellValues function. It creates a collection containing each salesperson’s name. It then creates a new workbook to contain the individual reports. The source worksheet is copied to this workbook, once for each name in the collection. Each copied worksheet is filtered to show all names except the one being reported on. The visible rows are then deleted and the filter turned off. The result is a workbook with one report per salesperson. Note that, because we used a filter, no sorting is required:

Sub CreateSalesReports()
Dim wsSales As Excel.Worksheet
Dim wbSalesReport As Excel.Workbook
Dim ListLastRow As Long
Dim collSalesPeople As Collection
Dim i As Long
Dim wsSalesPerson As Excel.Worksheet

Set wbSalesReport = Workbooks.Add
Set wsSales = ThisWorkbook.Sheets("Sales")
With wsSales
ListLastRow = .Range("A" & .Rows.Count).End(xlUp).Row
'create the unique list/collection of salespeople
Set collSalesPeople = GetUniqueCellValues(.Range("A2:A" & ListLastRow))
End With
'cycle through the salespeople, creating a worksheet/report for each
For i = 1 To collSalesPeople.Count
wsSales.Copy after:=wbSalesReport.Sheets(wbSalesReport.Sheets.Count)
Set wsSalesPerson = ActiveSheet
'filter to all other salespeople
With wsSalesPerson
.Range("A1").AutoFilter Field:=1, Criteria1:="<>" & collSalesPeople(i)
'delete the visible rows, leaving just those for the salesperson
.Range("2:" & ListLastRow).EntireRow.Delete
'name the worksheet
.Name = collSalesPeople(i)
.AutoFilterMode = False
End With
Next i
End Sub

Here’s the resulting workbook:

If you’re interested, Dennis Wallentin explains a different way to get unique values from a range, using Advanced Filter.

Userform Application-Level Events

Posted on August 10, 2012 by Doug Glancy

I’ve been fooling around with workbook and application-level events in UserForms. I’ve put them to good use in one or two projects, so thought I’d post about it. While thinking about the best way to present it, I ended up with a form that allows you to track all application-level events in an Excel instance. EventTracker looks like this (click the pic to for bigger one):

Warning: meandering post ahead

Before we get to that though, here’s how you can create a simple form that responds to all SheetSelectionChange events. First add a userform to a workbook in the Visual Basic Editor, then add a textbox to it. Paste this code into the form’s code module:

Private WithEvents app As Excel.Application

Private Sub UserForm_Initialize()
Set app = Application
End Sub

Private Sub app_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Me.TextBox1 = Target.Address(external:=True)
End Sub

The code creates a WithEvents Application variable which is used to track application-level events. In this case, we’ll track the SheetSelectionChange event, but you can select other ones by selecting “app” in the dropdown at the top left of the VBA editor and the event in the dropdown at the top right.

Before you run the form you need to set its ShowModal property to False (or there will be no application-level events to track). Or you could just add this code to the code above:

Private Sub UserForm_Activate()
Static Activating As Boolean
If Activating = False Then
Activating = True
Me.Hide
Me.Show vbModeless
End If
End Sub

I didn’t know the above would work until I tried it here. I don’t recommend it for any kind of serious coding, because of the static variable, but I like it. Basically the code only runs the first time UserForm_Activate runs. It hides the form and then shows it again modally, obviating the need to set the ShowModal property in design time or open the form from another module.

Now run the form and you’ll see that every SelectionChange event is reflected in Textbox1.

So, back to the EventTracker form. It has two listboxes, one that shows all the available events to track, and one that lists the events that have occurred. You can set the events to track to all or none, or just some. The listbox is set to MultiSelectExtended, which means you can use Shift and Control to select ranges. I also added code so that Ctrl-A selects the whole list. Plus there’s option buttons!

The listbox that tracks events gets resized as they are added. (The form is resizable as well.) It shows the event and its parameters, such as the name of the worksheet being activated. I changed the parameters slightly, separating out the “Target” argument for the SheetPivotTableUpdate event into a “Pivot” column. The code that adds a row to the recent events uses a paramarray, which is the first time I’ve ever used one.

Here are some of the things I learned while making, and running, the form:

1. Even when the “After pressing enter, move selection” option is off, the SheetSelectionChange event fires after you edit a cell and hit Enter. Who knew?

2. There are a bunch of new events in Excel 2010. I only included “WorkbookAfterSave,” “WorkbookNewChart” and “SheetPivotTableAfterValueChange” in this tool. The rest have to do with Pivot table OLAP cubes.

3. There’s still no BeforeReallyClosing event though.

4. The maximum number of items allowed in a listbox is subject to available resources. On my laptop that equated to 6,242,685, so I didn’t need code to handle overfilling the event tracking listbox.

5. I discovered Chip Pearson’s excellent form resizing API code and used it to set the form with a minimize button and the ability to be resized.

One bit of code that’s useful on its own resizes column widths in a listbox. It’s based on this Daily Dose of Excel post, which in turn was based on a very thorough post by Jan Karel Pieterse. I modified Dick’s code to include the headers in the resizing, and also to base the the resizing only on the listbox’s visible rows:

Private Sub SetLstRecentEventsColumnWidths()

'Uses a hidden label in the form to hold
'text from headers and visible rows and
'resize to the widest one for each column

Dim ColWidths As String
Dim MaxWidth As Double
Dim i As Long
Dim j As Long
Dim VisibleRowsCount As Long
Dim HeaderLabels As Collection
Dim HeaderLabelWidths As Double

'create the HeaderLabels collection
Set HeaderLabels = GetHeaderLabels
With Me.lstRecentEvents
'skip the code if no rows yet
If .TopIndex > -1 Then
VisibleRowsCount = Application.WorksheetFunction.Min((.ListCount - .TopIndex) - 1, .Height / lblHidden.Height)
For i = 0 To .ColumnCount - 1
'first get the header label width
Me.lblHidden.Caption = HeaderLabels(i + 1) & "MM"
MaxWidth = Application.WorksheetFunction.Max(Me.lblHidden.Width, MaxWidth)
'only want to resize for the visible rows
For j = .TopIndex To .TopIndex + VisibleRowsCount
Me.lblHidden.Caption = .Column(i, j) & "MM"
MaxWidth = Application.WorksheetFunction.Max(Me.lblHidden.Width, MaxWidth)
Next j
ColWidths = ColWidths & CLng(MaxWidth + 1) & ";"
HeaderLabels(i + 1).Left = HeaderLabels(1).Left + HeaderLabelWidths
HeaderLabels(i + 1).Width = MaxWidth
HeaderLabelWidths = HeaderLabelWidths + CLng(MaxWidth + 1)
MaxWidth = 0
Next i
.ColumnWidths = ColWidths
End If
End With
End Sub

Back to the EventTracker form again. As my father might say “The road is the destination.” Or is it “kindling is fire…?”

The downloadable zip file has a grid showing the events handled and a handy button to start Event Tracker. The workbook is .xlsm format, because if it was saved in .xls then the more recent events wouldn’t be available. You can still run it in XL 2003 as long as you’ve installed the compatibility pack. When running in an earlier version than 2010, events not supported in that version show up in the form module under “General,” rather than under “app.”

Copy Numbers With Formatting to Strings

Posted on July 4, 2012 by Doug Glancy

The other day a co-worker needed to convert the formatted numbers in cells to text strings in the same cells – text strings that still looked like the formatted cells. For example, a cell with the number 12.34 formatted as a dollar amount would be converted to the string “$12.34”. The same number formatted for percent with two decimal points would become the string “1234.00%”. Formatted as a date, it would become the string “1/12/1900 8:09:36 AM”. In other words, he wanted text strings that contain what your eyes see in the formatted cell.

So that this… becomes that.

It’s subtle, but you can see that the converted cells are now left-aligned and many of them have the green triangle indicating “number stored as text.” And the ISNUMBER formula in D2 has switched from TRUE to FALSE.

My co-workder needed this because his worksheet was feeding an ArcGIS web-based map, with the cell values being used for interactive tables, or something like that. With formatted numbers in the cells, the tables would show 12.34 for the above examples. By converting the numbers to strings, the data were correctly formatted.

I don’t know of any way to do this without VBA. In Excel we are able to format cells as text, but if you just apply the Text format to numbers you lose the formatting. If you format target cells as Text and then copy your formatted source cells over them, the target cells assume the source cells’ formatting. Pasting as Values loses the formatting. Converting to a csv loses the formatting. So, I think VBA is required for this.

The VBA Range object has a Text property, which returns the contents of the cell as they appear to the human eye, exactly what we want. Using this property I was able to write a few lines of code and convert my co-worker’s spreadsheet:

Dim cell as Excel.Range
For Each cell In Selection
CellText = cell.Text
'@ is the Text format
cell.NumberFormat = "@"
cell.Value2 = CellText
Next cell

Since the number of cells was very small, this ran quickly and did what he wanted. The cells were now pushed into the interworld with their formatting intact.

Looping through cells as above is quite slow. Running it on 20,000 rows with 40,000 cells takes about 20 seconds on my laptop. Ideally, you want to assign all the cells to a variant array, process the elements of the array, and then plunk the array back into the range of cells.

I’ve done this with the Range object’s Value2 property before and wrote some code to do the same with Text. However, my variant array kept returning Null after doing something like:

Dim varCells as Variant
varCells = Selection.Text

I found this Charles Williams post where he points out that, unlike Value or Value2, assigning the Text property of a range to a variant array returns Null, unless all the cells have the same value and format.

So I changed the code to loop through the cells one at a time and assign their Text property to a two-dimensional String array. Fortunately, we can still assign the whole array back to a range.

Charles’ post revealed another interesting gotcha: when looping through cells’ Text properties and assigning them to an array your code gets progressively slower, but only if the range has rows with different heights in it. In my testing I noticed that even if all the rows are set back to the same height this weirdness persists.

The solution is to, every so often, select the cell that’s being processed. In my case, I chose to do it every 1000 rows. This won’t work if ScreenUpdating is set to False. This creates an additional reason to not process the cells one at a time, as all those writes back to the spreadsheet would slow things down even more.

(That’s a funky bug isn’t it? Makes you use Select in your code and leave Screenupdating on. I swear, when I started, I thought this would be a 400 word post! Nothing is simple in Excel, at least nothing I write about.)

One other issue is that if your columns are too narrow for a number and a cell is displaying “####”, the resulting text string will be “####”. I included a line in the code below to autofit the columns, but I’m not sure it will fix every situation.

With this code 20,000 rows with 40,000 cells takes about four seconds. This is only slightly worse than the three seconds it takes if the row heights are all the same and the Select fix isn’t needed, and much better than the 20 seconds if the row heights are different and Charles’ Select fix isn’t used.

Sub NumberToStringWithFormat(rng As Excel.Range)
Dim Texts() As String
Dim i As Long, j As Long

'This might prevent "###" if column too narrow
rng.EntireColumn.AutoFit
'Can't use variables in Dim
ReDim Texts(1 To rng.Rows.Count, 1 To rng.Columns.Count)
For i = 1 To rng.Rows.Count
'Charles' fix for slow code with Text
If i Mod 1000 = 0 Then
rng.Range("A1").Offset(i).Select
End If
For j = 1 To rng.Columns.Count
Texts(i, j) = rng.Cells(i, j).Text
Next j
Next i
'@ is the Text format
rng.NumberFormat = "@"
rng.Value2 = Texts
End Sub

Regex Function to Sum Numbers in String

Posted on June 25, 2012 by Doug Glancy

I recently needed to sum the numeric parts of strings in cells. For example, a cell with “4 calling birds, 3 dog night” would equal seven. So I came up with a regex function to sum numbers in strings. Actually, the regex identified the numbers, and the rest was easy.

The original version worked for things like the following: positive integers with no commas:

For those of you not familiar with the basics of regex matching, here’s a short sample that takes a string like those above, applies a simple regex pattern for positive integers and sums the matches. It uses early binding, so you need to set a reference to “Microsoft VBScript Regular Expressions 5.5” in the VBE.

Sub BasicRegexFind()
'Set a reference to "Microsoft VBScript Regular Expressions 5.5"
Dim regex As VBScript_RegExp_55.RegExp
Dim rgxMatch As VBScript_RegExp_55.Match
Dim rgxMatches As VBScript_RegExp_55.MatchCollection
Dim StringToSearch As String

StringToSearch = "4 calling birds, 76 Trombones"

Set regex = New VBScript_RegExp_55.RegExp
With regex
'Find all matches, not just the first
.Global = True
'search for any integer matches
'"\d+" is the same as "[0-9]+"
.Pattern = "\d+"
'built-in test for matches!
If .Test(StringToSearch) Then
'if matches, create a collection of them
Set rgxMatches = .Execute(StringToSearch)
For Each rgxMatch In rgxMatches
Debug.Print rgxMatch
Next rgxMatch
End If
End With

End Sub

The VBScript regex object is easy to work with, complete with a “Test” method that tells you if there’s any matches, and a collection of matches you can loop through with For/Next.

While the object is pretty straightforward, the concepts are confusing, and the syntax is nuts! I don’t know how much I’ll ever memorize. So before moving on to my voyage of discovery in developing a better function, here’s a couple of resources that helped me. The first site I turn to is regular-expressions.info. This link deals specifically with VBScript regex engine, but there’s many pages of tutorials on syntax and concepts. This tutorial by Patrick Matthews on Experts Exchange focuses on VBA and also contains a bunch of powerful regex-based “wrapper” functions you can use to match and replace text, without having to know how they work. Finally, you can take a look at the many masterful VBA/regex solutions provided by brettdj to real-world questions asked on stackoverflow.

The match pattern used above – “\d+” – worked for my original task, as I was adding only positive integers in strings with no other numbers of any sort. But what about…

sub-strings with numbers that shouldn’t be counted, like “Catch-22” or “7-Eleven”
decimal number
negative numbers
numbers with commas
non-numeric strings with nothing but numerals and periods, like IP addresses

In other words, we’re looking for substrings containing only numerals, periods, commas, or plus or minus signs. Further, after the optional plus or minus sign, any legitimate match must start with either a single digit or a decimal point followed by a digit.

Regular expressions includes a zero-length match construct – “\b” – that matches a “word” boundary. I thought something like “\b\d+\b” would match a positive integer bounded by a space. But it turns out that a period is a “non-word” character, so “192” and all the other numeric sections of “192.168.0.1” are seen as words and matched. Also, it would split decimal numbers into their integer and decimal parts, so 3.14159 would yield two matches of 3 and 14159, without the decimal. Alas, “\b” was no use to me. In addition, I realized that I was going to have to capture entire strings, such as IP addresses, because otherwise I’d generate a bunch of false positives from their parts. They’d need to be deleted from the real positives with an IsNumeric test after the regex matching was done.

Then I figured I could just check for a space preceding and following the match. That almost works, but since the space is part of the match, it only works for the first occurrence. With a string like “22 33” the space between 22 and 33 only gets counted as the space after 22. The regex doesn’t recognize that 33 has a space in front of it because it’s already moved on down the road.

What ended up working was a “Lookahead.” This is another zero-length match construct that checks the character following the pattern to be matched, without including it in the match. It sees the space at the end of 22, and it’s still available to be matched as the space at the beginning of 33. This is key, since the VbScript regex engine, unlike others, has no Lookbehind construct. So the pattern includes a Lookahead for a space. The positive Lookahead pattern for a space is (?= ).

Lookaheads also help ensure that commas only appear in reasonable places. One states that commas match only if they’re followed by three digits, the second only allows decimal points that aren’t followed by a comma. The negative Lookahead pattern for a comma is (!=,). (All of my comma and period usage here is US-centric and would need to be adjusted for those using different decimal marks or thousands separators).

Finally, the pattern only matches if it starts with a space or the zero-length begin-of-string construct, “^”. And, if the positive Lookahead for a space failed, it must end at the end-of-string ($). Here’s the full pattern:

(^| )[-+]?(\d|\.\d)(\d+|\.(?![.,])|(,(?=\d{3})))*((?= )|$)"

Broken down it says:

(^| )

– must begin with a space or be at the beginning of the string

[-+]?

– followed by zero or one occurrences of either a plus or minus sign

(\d|\.\d)

– followed by a single digit, or
a decimal point that’s followed by a single digit

(\d+|\.(?![.,])|(,(?=\d{3})))*

– followed by zero or more instances of
one or more integers, or
a decimal point that’s not followed by a decimal point or comma, or
a comma that’s followed by three integers

((?= )|$)

– match only if all of the above is followed by a space,
or if it’s at the end of the string

Since a valid match can have a space at the beginning the code includes a trim statement. It also strips out commas, which are allowed in the regex, but won’t pass IsNumeric. Here’s the complete function. It’s late-bound:

Function SumNumsInString(StringToSearch As String) As Double
'Finds numbers within a string and sums them
'Late-binding, so no reference needed

Dim regex As Object
Dim rgxMatch As Object
Dim rgxMatches As Object
Dim NumSum As Double

Set regex = CreateObject("vbScript.RegExp")
With regex
.Global = True
.Pattern = "(^| )[-+]?(\d|\.\d)(\d+|\.(?![.,])|(,(?=\d{3})))*((?= )|$)"
'non-submatch-capuring version
'"(?:^| )[-+]?(?:\d|\.\d)(?:\d+|\.(?![.,])|(?:,(?=\d{3})))*(?:(?= )|$)"
If .Test(StringToSearch) Then
Set rgxMatches = .Execute(StringToSearch)
For Each rgxMatch In rgxMatches
If IsNumeric(Replace(rgxMatch, ",", "")) Then
NumSum = NumSum + Replace(rgxMatch, ",", "")
End If
Next rgxMatch
End If
End With
SumNumsInString = NumSum
End Function

There’s also a Regexp.Submatch property – a collection that contains every submatch in the match, where a submatch is a piece of the pattern inside parentheses. So I could have checked if the first submatch was a space and only used the succeeding submatches. This would have eliminated the need to Trim the string, but seems more complex.

Since I didn’t use the submatches I could have included regex characters that tell the engine not the store them, speeding up the regex. Then the pattern would look like the commented one in the code, where the “?:” after each opening paren performs that function:

(?:^| )[-+]?(?:\d|\.\d)(?:\d+|\.(?![.,])|(?:,(?=\d{3})))*(?:(?= )|$)

That means there’s three types of question marks in one pattern: the ones just mentioned, the ones that follow “[-+}” and means to match it zero or one times, and the one that’s part of the Lookahead “?=” pattern. Whew!

Anyways, here’s a more complex version of the first table, with the intended numbers being found:

Clearly this isn’t a foolproof function (D’oh!). My intent was firstly to learn about regexes while having fun, and also to outline my trial-and-error process in a way that may help others. So, although I researched concepts and syntax on the web, I didn’t look at anybody’s actual solutions for this type of function, as I wanted to just hack away on my own.

As always, I’m sure there’s a better way, and I’d love to hear yours!

Data Normalizer – the SQL

Posted on May 8, 2012 by Doug Glancy

In Data Normalizer I showed you how I normalize worksheet data using arrays and For/Next loops. I’ve been doing a fair amount of SQL in VBA lately, and thought I’d rewrite the code using that approach.

A little searching revealed the T-SQL/SQL Server “Unpivot” command, which normalizes your data and sets the new field names all in one swell foop. It’s not available in Access/Jet SQL though, so can’t be used on Excel. Instead, the preferred method is to use a series of Selects that pick one normalizing column at a time (along with the repeating columns) and Unions them together.

I tried ADO first, using the method of SaveCopyAs’ing the workbook-to-be-normalized in order to avoid the ADO memory leak. ADO was way slower than DAO, something like four times slower with 3000 records of 16 columns. So I went with DAO, which still takes about twice as long as the array method. Turning the ADO to DAO was easy, especially with this concise sample from XL-Dennis.

As Jeff Weir pointed out in a comment, this does require a reference (Tools>References) to the Microsoft DAO 3.5 Object Library. I’ve been switching some code over to late binding, but there doesn’t seem to be much enthusiasm for this with DAO. I’m not sure if that’s because it’s so pervasive and well-established, or for some other reason.

The core logic of the routine is pretty simple. In pseudo-English:

For each column in the columns to be normalized
Select all repeating columns
and Select (create) a new column, giving it the same name each time ("Team" in this example)
and Select the column with that team's data, giving it the same name each time ("Home Runs" in this example
and Union it to the Select statement created in the next loop iteration

Without further ado (heh heh) here’s the routine.

'Requires a reference to DAO 3.5 or later
'Arguments
'List: The range to be normalized.
'RepeatingColsCount: The number of columns, starting with the leftmost,
' whose headings remain the same.
'NormalizedColHeader: The column header for the rolled-up category.
'DataColHeader: The column header for the normalized data.
'NewWorkbook: Put the sheet with the data in a new workbook?
'
'NOTE: The data must be in a contiguous range and the
'rows that will be repeated must be to the left,
'with the rows to be normalized to the right.

Sub NormalizeList_SQL_DAO(List As Excel.Range, RepeatingColsCount As Long, _
NormalizedColHeader As String, DataColHeader As String, _
Optional NewWorkbook As Boolean = False)

Dim FirstNormalizingCol As Long, NormalizingColsCount As Long
Dim RepeatingColsHeaders As Variant, NormalizingColsHeaders As Variant
Dim RepeatingColsIndex As Long, NormalizingColsIndex As Long
Dim wbSource As Excel.Workbook, wbTarget As Excel.Workbook
Dim wsTarget As Excel.Worksheet

Dim daoWorkSpace As DAO.Workspace
Dim daoWorkbook As DAO.Database
Dim daoRecordset As DAO.Recordset
Dim strSql As String
Dim strExtendedProperties As String

With List
'If the normalized list won't fit, you must quit.
If .Rows.Count * (.Columns.Count - RepeatingColsCount) > .Parent.Rows.Count Then
MsgBox "The normalized list will be too many rows.", _
vbExclamation + vbOKOnly, "Sorry"
Exit Sub
End If
'List.Parent.Parent is the lists Workbook
Set wbSource = List.Parent.Parent
'The columns to normalize must be to the right of the columns that will repeat
FirstNormalizingCol = RepeatingColsCount + 1
NormalizingColsCount = .Columns.Count - RepeatingColsCount
'Get the header names of the repeating columns
RepeatingColsHeaders = List.Cells(1).Resize(1, RepeatingColsCount).Value
'Get the header names of the normalizing columns
NormalizingColsHeaders = List.Cells(FirstNormalizingCol).Resize(1, NormalizingColsCount).Value

strSql = vbNullString
'loop through each normalizing column
For NormalizingColsIndex = 1 To NormalizingColsCount
'Create an individual Select for the normalizing column
strSql = strSql & " SELECT "
'Select all the repeating columns
For RepeatingColsIndex = 1 To RepeatingColsCount
strSql = strSql & RepeatingColsHeaders(1, RepeatingColsIndex) & ", "
Next RepeatingColsIndex
'Select the normalizing column and assign the NormalizedColHeader field name
'and select the data being counted and assign it the DataColHeader field name
strSql = strSql & "'" & NormalizingColsHeaders(1, NormalizingColsIndex) & "'" & " AS " & NormalizedColHeader & _
", " & NormalizingColsHeaders(1, NormalizingColsIndex) & " AS " & DataColHeader
strSql = strSql & " FROM [" & List.Parent.Name & _
"$" & List.Address(rowabsolute:=False, columnabsolute:=False) & "]"
If NormalizingColsIndex < NormalizingColsCount Then
'Union the Select statements created for the normalizing columns
strSql = strSql & " UNION ALL"
End If
Next NormalizingColsIndex
End With
'Set up the DAO connection
strExtendedProperties = "Excel 8.0;HDR=Yes;IMEX=1"
Set daoWorkSpace = DBEngine.Workspaces(0)
Set daoWorkbook = daoWorkSpace.OpenDatabase(wbSource.FullName, False, True, strExtendedProperties)
Set daoRecordset = daoWorkbook.OpenRecordset(strSql, dbOpenForwardOnly)

'Put the normal data in the same workbook, or a new one.
If NewWorkbook Then
Set wbTarget = Workbooks.Add
Set wsTarget = wbTarget.Worksheets(1)
Else
Set wbSource = List.Parent.Parent
With wbSource.Worksheets
Set wsTarget = .Add(after:=.Item(.Count))
End With
End If

'copy the headers and DAO recordset to the new worksheet
With wsTarget
.Cells(1, 1).Resize(1, RepeatingColsCount).Value = RepeatingColsHeaders
.Cells(1, RepeatingColsCount + 1) = NormalizedColHeader
.Cells(1, RepeatingColsCount + 2) = DataColHeader
.Cells(2, 1).CopyFromRecordset daoRecordset
End With

'clean up
daoRecordset.Close
daoWorkbook.Close
daoWorkSpace.Close
Set daoRecordset = Nothing
Set daoWorkbook = Nothing
Set daoWorkSpace = Nothing
End Sub

If you break after strSql is created, it looks like this:

SELECT League, Year, 'ATL' AS Team, ATL AS HomeRuns FROM [HR-NL$A1:R110]
UNION ALL
SELECT League, Year, 'CHC' AS Team, CHC AS HomeRuns FROM [HR-NL$A1:R110]
UNION ALL
...
SELECT League, Year, 'MIL' AS Team, MIL AS HomeRuns FROM [HR-NL$A1:R110]

Call it like this:

NormalizeList_SQL_DAO ActiveSheet.UsedRange, 2, "Team", "HomeRuns", False

One pitfall of this SQL version is the mixed data-type issue with the Excel ISAM driver. In this example it converts all the home run counts from numbers to text because of the blanks in the data.

All in all, I think the array approach is better than SQL for this use. The core skill of creating SQL in VBA is a valuable one though, and one I’m glad to be developing.

I updated the Data Normalizer .xls to include this code.

Create Pivot Table Named Ranges

Posted on April 25, 2012 by Doug Glancy

I need to calculate percentiles from subsets of data in a pivot table. In order to refer to pivot table fields, it sure would be nice if they had dynamic named ranges. So I wrote some code to create pivot table named ranges.

Programming pivot tables is fun. The extensive object model is a VBA wonderland with treats around every turn. There are great web sites out there with excellent pivot table coding samples – Contextures leaps to mind. In terms of identifying PivotFields, DataFields and other pivot table ranges, Jon Peltier wrote a superb post in 2009 that’s still generating discussion.

My code is pretty simple. It cycles through the data fields, and any other visible fields, in the specified pivot table and adds a named range for each one to the pivot table’s worksheet:

Sub RefreshPivotNamedRanges(pvt As Excel.PivotTable)
Dim ws As Excel.Worksheet
Dim pvtField As Excel.PivotField
Dim FieldType As String

With pvt
Set ws = .Parent
ClearOldNames ws, pvt
For Each pvtField In .DataFields
AddNamedRange ws, pvt.Name, "Data", pvtField.SourceName, pvtField.DataRange.Address
Next pvtField
For Each pvtField In .PivotFields
Select Case pvtField.Orientation
Case xlHidden
GoTo next_one
Case xlPageField
FieldType = "Page"
Case xlDataField
FieldType = "Data"
Case xlRowField
FieldType = "Row"
Case xlColumnField
FieldType = "Col"
End Select
AddNamedRange ws, pvt.Name, FieldType, pvtField.Name, pvtField.DataRange.Address
next_one:
Next pvtField
End With
End Sub

The PivotField.Orientation property has five enumerated constants that tell you what type of field it is – xlDataField, xlRowField, etc. The For/Next loop skips over the ones that come up xlHidden and processes the rest. Strangely, even though there’s a xlDataField type, and even though I can refer to pvt.PivotFields(“Sum of Home Runs”), the data fields don’t actually show up when cycling through the PivotFields. Instead, to get those fields the code first cycles through the pivot table’s DataFields collection.

When calling the AddNamedRange routine for a DataField, the codes passes its SourceName, not the Name. So in this example, the new name will include “Home Runs,” not “Sum of Home Runs.” You may want to pass the Name instead.

This next routine does what it says and clears out the previous range names associated with the pivot table. It’s not fool-proof. For example, if the pivot table name was changed, it won’t find the range names. I should probably use the pivot table’s Tag property to store names that won’t get changed:

Sub ClearOldNames(ws As Excel.Worksheet, pvt As Excel.PivotTable)
Dim nm As Excel.Name

For Each nm In ws.Names
If InStr(nm.Name, "!_" & pvt.Name) > 0 Then
nm.Delete
End If
Next nm
End Sub

The routine below adds the worksheet-level names to the pivot table’s sheet. It calls a function that replaces spaces and other characters that aren’t allowed in range names (code at the end of the post). It also adds a “_” at the beginning of the name to hopefully avoid illegal names like “A1”:

Sub AddNamedRange(ByRef ws As Excel.Worksheet, ByVal PivotName As String, ByVal FieldType As String, ByVal PivotFieldName As String, ByVal PivotFieldAddress As String)
Dim CleanedRangeName As String

CleanedRangeName = "_" & GetCleanedRangeName(PivotName & "_" & FieldType & "_" & PivotFieldName, "_")
ws.Names.Add Name:=CleanedRangeName, RefersTo:="=" & PivotFieldAddress & ""
End Sub

To automate this stuff, put the code in a regular module and call RefreshPivotNamedRanges from a PivotTableUpdate event. The names will be regenerated each time the pivot table is refreshed, either manually or when you drag a field, or however.

So now my Percentile array formula can find the value for the selected year and percentile:

Here’s the code to get the legal range names. You’ll need to set a reference to Microsoft VBScript Regular Expressions (at least if you’re an early binder):

Function GetCleanedRangeName(RangeName As String, SpaceReplacement As String) As String
Dim NewName As String

'the "" character escapes the Regex "reserved" characters
'x22 is double-quote
NewName = Regex_Replace(RangeName, "[\\\^\|\[\]\$\{\}\-x22/`~!@#%&=;:<>]", "", False)
'get rid of multiple contiguous spaces
NewName = Application.WorksheetFunction.Trim(NewName)
'255 is the length limit for a legal name
NewName = Left(Replace(NewName, " ", SpaceReplacement), 255)
GetCleanedRangeName = NewName
End Function

Function Regex_Replace(OriginalString As String, Pattern As String, Replacement, varIgnoreCase As Boolean) As String
' Function matches pattern, returns true or false
' varIgnoreCase must be TRUE (match is case insensitive) or FALSE (match is case sensitive)
' Use this string to replace double-quoted substrings - """[^""\r\n]*"""
Dim objRegExp As VBScript_RegExp_55.RegExp

Set objRegExp = New VBScript_RegExp_55.RegExp
With objRegExp
.Pattern = Pattern
.IgnoreCase = varIgnoreCase
.Global = True
End With
Regex_Replace = objRegExp.Replace(OriginalString, Replacement)
Set objRegExp = Nothing
End Function

This has undergone a massive .5 days of testing, so I can guarantee there’s glitches. But if you’d like to give it a spin, here you go. It’s an Excel 2007/10 file as earlier versions don’t support the “Repeat All Item Labels” pivot setting that I rely on for the Percentile array formula. Other than that, it works just as well in Excel 2003.

Prompt to Save Addins

Posted on April 18, 2012 by Doug Glancy

I’m pretty good about saving my work, and probably hit Ctrl-S a couple hundred times a day. And of course, as long as things don’t crash, Excel makes it hard to lose your work. One exception is addins, which don’t trigger a save prompt when you close them after making changes, at least when the IsAddin property is True. So I have a routine in my most-used addins that reminds me to save them. But I don’t have it in all of them. The other day this bit me, and I lost 10 minutes of work on an xlam. I decided to generalize my prompt to save addins and put it in an application-level event in my main utility addin. (These decisions come easy; what’s more fun than building a new tool?) This way I’m prompted to save any time I close an addin that I’ve changed.

If you’ve never used application-level events, Chip Pearson’s site has some good information. Okay, here’s how you can add this code to your favorite utility addin (personal.xls will do nicely).

Create a Class called “clsApplication” and paste this code into it:

Public WithEvents app As Excel.Application

Private Sub App_WorkbookBeforeClose(ByVal wb As Workbook, Cancel As Boolean)
If wb.IsAddin And Not wb.Saved Then
If MsgBox(wb.Name & "Addin" & vbCrLf & "is unsaved. Save?", _
vbExclamation + vbYesNo, "Unsaved Addin") = vbYes Then
If ExcelInstanceCount > 1 Then
MsgBox "More than one Excel instance running." & vbCrLf & _
"Save cancelled", _
vbInformation, "Sorry"
Exit Sub
Else
wb.Save
End If
End If
End If
End Sub

Create a global variable to hold the class instance. At the top of a regular code module (before any procedures) put this line:

Public cApplication As clsApplication

(I like to put all my global variables like the one above in a single module, called modGlobals.)

In the ThisWorkbook WorkbookOpen event for your utility addin, put this code:

Set cApplication = New clsApplication
Set cApplication.app = Excel.Application

One problem is that when an addin is saved with more than one instance of Excel open, it gets saved to a new location (maybe the folder of ActiveWorkbook?). So I added code to the BeforeClose event to cancel the save if that’s true. Here’s the function that does the checking:

Function GetExcelInstanceCount() As Long
Dim hwnd As Long
Dim i As Long
Do
hwnd = FindWindowEx(0&, hwnd, "XLMAIN", vbNullString)
i = i + 1
Loop Until hwnd = 0
GetExcelInstanceCount = i - 1
End Function

One last thing to do is add code to my global error handler that re-instantiates the cApplication.Class and its App property if they’ve gotten lost, which can easily happen during debugging.