Locating PivotItem Subtotals

Locating PivotItem Subtotals

I’m either on a roll or in a rut: here’s one more post about pivot field stuff. Last time I posted about determining whether a give pivot field has visible subtotals. This time I’ll tell you how to find them. The solution again relies on my new friend, the PivotCell object. My main function actually locates PivotItem subtotals, not a PivotField’s. I then wrap that function in another routine to deal with all of a PivotField’s PivotItems.

Here’s the VBA:

Function GetPivotItemSubtotalRanges(pvtItem As Excel.PivotItem) As Excel.Range()
Dim pvt As Excel.PivotTable
Dim pvtField As Excel.PivotField
Dim cell As Excel.Range
Dim ItemTester As Excel.PivotItem
Dim PivotItemSubtotalRanges() As Excel.Range

If Not pvtItem.Visible Then
   Exit Function
End If

'I can't figure a better way to get the containing pivot table
Set pvt = pvtItem.DataRange.Cells(1).PivotTable
Set pvtField = pvtItem.Parent
'Cells with subtotal PivotCellType are in ColumnRange or RowRange
For Each cell In Union(pvt.ColumnRange, pvt.RowRange)
   Set ItemTester = Nothing
   On Error Resume Next
   'Only test cells with an associated PivotItem
   Set ItemTester = cell.PivotItem
   On Error GoTo 0
   With cell.PivotCell
      If Not ItemTester Is Nothing Then
         If (.PivotCellType = xlPivotCellSubtotal Or .PivotCellType = xlPivotCellCustomSubtotal) And cell.PivotField.DataRange.Address = pvtField.DataRange.Address And cell.PivotItem.DataRange.Address = pvtItem.DataRange.Address Then
            RedimRanges PivotItemSubtotalRanges
            If pvtField.Orientation = xlColumnField Then
               Set PivotItemSubtotalRanges(UBound(PivotItemSubtotalRanges)) = Intersect(cell.EntireColumn, pvt.DataBodyRange)
            ElseIf pvtField.Orientation = xlRowField Then
               Set PivotItemSubtotalRanges(UBound(PivotItemSubtotalRanges)) = Intersect(cell.EntireRow, pvt.DataBodyRange)
            End If
         End If
      End If
   End With
Next cell

GetPivotItemSubtotalRanges = PivotItemSubtotalRanges
End Function

How It Works

Be sure to read the previous post on this topic for background of how I got here.

With that background in hand, what the function above does is fairly simple. It loops through the RowRange and ColumnRange of a PivotItem’s pivot table. It looks for cells with a Range.PivotItem property that matches the PivotItem passed to the function, and which have a Range.PivotCellType of Subtotal or CustomSubtotal. If so then that PivotItem subtotal range is set to the intersection of the pivot table’s DataBodyRange and the row or column of the cell being tested. The subtotal range is added to the array of subtotal ranges returned by the function.

The PivotField Routine

Here’s an example of using the GetPivotItemSubtotalRanges function. This Sub takes a PivotField as its argument and selects all of it’s subtotals.

Sub SelectPivotFieldSubtotals(pvtField As Excel.PivotField)
   Dim pvtItem As Excel.PivotItem
   Dim PivotItemSubtotalRanges() As Excel.Range
   Dim PivotFieldSubtotals As Excel.Range
   Dim i As Long

   If Not PivotFieldSubtotalsVisible(pvtField) Then
      MsgBox "No Visible Subtotals"
      GoTo exit_point
   End If
   For Each pvtItem In pvtField.PivotItems
      If pvtItem.RecordCount > 0 Then
         PivotItemSubtotalRanges = GetPivotItemSubtotalRanges(pvtItem)
         For i = LBound(PivotItemSubtotalRanges) To UBound(PivotItemSubtotalRanges)
            If PivotFieldSubtotals Is Nothing Then
               Set PivotFieldSubtotals = PivotItemSubtotalRanges(i)
            Else
               Set PivotFieldSubtotals = Union(PivotFieldSubtotals, PivotItemSubtotalRanges(i))
            End If
         Next i
      End If
   Next pvtItem
   If i > 0 Then
      PivotFieldSubtotals.Select
   End If

exit_point:
End Sub

Stray Code Bits You’ll Need to Run the Above

This is the function that checks whether a PivotField has visible subtotals, and that I posted about previously:

Function PivotFieldSubtotalsVisible(pvtFieldToCheck As Excel.PivotField) As Boolean
Dim pvt As Excel.PivotTable
Dim cell As Excel.Range

With pvtFieldToCheck
   'Only row and column fields can show subtotals,
   If Not (.Orientation = xlColumnField Or .Orientation = xlRowField) Then
      GoTo exit_point
   End If
   Set pvt = .Parent
   For Each cell In Union(pvt.ColumnRange, pvt.RowRange)
      If cell.PivotCell.PivotCellType = xlPivotCellSubtotal Or cell.PivotCell.PivotCellType = xlPivotCellCustomSubtotal Then
         If cell.PivotCell.PivotField.Name = .Name Then
            PivotFieldSubtotalsVisible = True
            GoTo exit_point
         End If
      End If
   Next cell
End With

exit_point:
End Function

This one is because I want to hide the fact that I’m Redimming a lot:

Sub RedimRanges(ByRef SubtotalDataRanges() As Excel.Range)
If IsArrayEmpty(SubtotalDataRanges) Then
    ReDim SubtotalDataRanges(1 To 1)
Else
    ReDim Preserve SubtotalDataRanges(LBound(SubtotalDataRanges) To UBound(SubtotalDataRanges) + 1)
End If
End Sub

This is Chip Pearson’s array check:

Public Function IsArrayEmpty(Arr As Variant) As Boolean
'Chip Pearson
Dim LB As Long
Dim UB As Long

Err.Clear
On Error Resume Next
If IsArray(Arr) = False Then
    ' we weren't passed an array, return True
    IsArrayEmpty = True
End If
UB = UBound(Arr, 1)
If (Err.Number <> 0) Then
    IsArrayEmpty = True
Else
    Err.Clear
    LB = LBound(Arr)
    If LB > UB Then
        IsArrayEmpty = True
    Else
        IsArrayEmpty = False
    End If
End If
End Function

And this is what I attached to a button. Select a cell in a pivot table and if that cell’s PivotField has subtotals they will be highlighted:

Sub test()
SelectPivotFieldSubtotals ActiveCell.PivotField
End Sub

Subtotals Selected

In Conclusion

Whew! That feels like a lot of code with maybe not enough explanation. I plan to wrap up all this pivot field selection stuff soon with a post about my new-and-improved Per-Item Conditional Formatting tool.

MenuRighter Now 64-bit Compatible

MenuRighter Now 64-bit Compatible

I’ve updated MenuRighter, and it now works with 32-bit and 64-bit versions of Office 2010 through 2016. I’ve had a few requests for a 64-bit version, so hopefully this will help some folks.

If you’re not familiar, MenuRighter is my addin that allows extensive customization of your right-click menus.There’s lots of information on it at the page linked below.

The download at the following page now works with both 32-bit and 64-bit versions of Excel 2010 through 2016. Please let me know if you have any questions or find any issues with it:

MenuRighter 2010 and Later

MenuRighter v2 in repose

Pivot Table Pivot Chart Navigator

Pivot Table Pivot Chart Navigator

This post is about navigating between pivot tables and pivot charts. The sample workbook contains a Pivot Table and Pivot Chart Navigator userform that lists the workbook’s pivot tables and takes you to them or their associated charts. The workbook also adds buttons to the chart and pivot table right-click menus. These buttons take you to the associated pivot chart or table. I used Ribbon XML for this last part since later versions of Excel don’t allow modification of the chart context menus with VBA. The downloadable workbook can be easily converted to an addin.

pivot chart context menu

I used to eschew pivot charts as far too clunky. Recently though I was given a project that contained many pivot charts. It seemed that, unless I’d just gotten much less picky (not likely), pivot charts work much better than I remembered. This impression was confirmed in a Jon Peltier post, so I know it’s true.

Using XML to Add to Right-Click Menus

As mentioned above, I’ve added a “Go to Source Pivot” button at the bottom of the chart context menu. I’d never used Ribbon XML to make a right-click menu before. The XML part is straightforward.

To create the button I used the Custom UI Editor and added a ContextMenu section to the XML. I also used the Microsoft’s NameX addin to figure out the name that refers to the chart context menu (ContextMenuChartArea) The XML for the chart and pivot table context menus is below. All of this, including links to the Custom UI Editor and the NameX addin, is covered very nicely in this MSDN post.

Since I’m already forced to use XML to modify the chart context menu, I used it for the pivot table context menu too, even though it can still be modified with VBA:

<contextMenus>
    <contextMenu idMso="ContextMenuChartArea">
     <button id="cmdGoToSourcePivot" label="Go To Source Pivot"
        onAction="cmdGoToSourcePivot_onAction"
        getVisible = "cmdGoToSourcePivot_GetVisible"/>
    </contextMenu>
    <contextMenu idMso="ContextMenuPivotTable">
     <button id="cmdGoToPivotChart" label="Go To Pivot Chart"
        onAction="cmdGoToPivotChart_onAction" />
    </contextMenu>
</contextMenus>

VBA to Go To Source Pivot
The code to go to the source pivot is similar to that in my Finding a Pivot Chart’s Pivot Table post. It looks at the charts PivotLayout property, which only exists if a chart is based on a pivot table. I use this same property in the RibbonInvalidate method to only show the “Go To Pivot Table” button when the chart is a pivot chart. That’s one thing I like about programming the ribbon: the code to show or hide tabs, buttons and other controls is generally simpler than it is when using VBA.

VBA to Go To Pivot Chart
The code to go to a pivot table’s chart loops through all chart sheets and charts on worksheets looking for one whose source range is the pivot table’s range:

Function GetPivotChart(pvt As Excel.PivotTable) As Excel.Chart
Dim wbWithPivots As Excel.Workbook
Dim ws As Excel.Worksheet
Dim chtObject As Excel.ChartObject
Dim cht As Excel.Chart

Set wbWithPivots = pvt.Parent.Parent
For Each cht In wbWithPivots.Charts
    If Not cht.PivotLayout Is Nothing Then
        If cht.PivotLayout.PivotTable.TableRange1.Address(external:=True) = pvt.TableRange1.Address(external:=True) Then
            Set GetPivotChart = cht
            Exit Function
        End If
    End If
Next cht
For Each ws In wbWithPivots.Worksheets
    For Each chtObject In ws.ChartObjects
        Set cht = chtObject.Chart
        If Not cht.PivotLayout Is Nothing Then
            If cht.PivotLayout.PivotTable.TableRange1.Address(external:=True) = pvt.TableRange1.Address(external:=True) Then
                Set GetPivotChart = cht
                Exit Function
            End If
        End If
    Next chtObject
Next ws
End Function

PivotNavigator Form
The other element of the sample workbook is a simple-yet-powerful form that navigates through a workbook’s pivot tables and pivot charts.

pivot navigator form

The form opens up with a list of all the pivot tables in the active workbook. Selecting an item in the form list takes you to the selected pivot. Use the Ctrl key with the left and right arrows to toggle between a pivot and its associated chart.

The form is modeless and responds to selection changes in the workbook, updating the list selection when you click into a different pivot or chart. This functionality uses VBA from my last post, which raises an event every time any chart in a workbook is selected.

Download
The sample workbook has the modified right-click menus, the navigation form and a button in the Developer tab to start the form. There’s even instructions!

Track ActiveCell Movement Within Selection

Track ActiveCell Movement Within Selection

I searched the internet a bit before deciding that neither Excel or the forums have a way to track Activecell movement in a Selection. So, even though I don’t have the most pressing need for such an event, I spent several quality hours coding one.

The Issue
Here’s what I’m talking about. You can capture cell activation using Selection_Change code:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Me.Range("A2") = ActiveCell.Address
Me.Range("B2") = ActiveCell.Value
End Sub

Selection Change

But this doesn’t capture cell activation within a selection, the kind that happens when you select an area and then tab through it:

No ActiveCell Change

I noticed this while creating a little ActiveCell Viewer form. My solution is to capture TAB key presses using Application.OnKey. This is a little clunky in a couple of ways, but it seems to work.

My Solution
So my userform uses OnKey to capture the Tab press when a Selection has more than one cell. Now I know when the active cell is changing within a selection, so that’s good. The hard part is that, since I’ve killed the normal Tab behavior, I have to recreate it in VBA with code that moves the ActiveCell one cell forward. Before I can do that I need to define the active cell’s location in terms of the selection.

Basically, the code cycles through each cell in each Area of the Selection. The Areas cycle through in the order they were selected. Tab cycles through each cell of an Area from top to bottom, right to left no matter how you selected the Area.

A Little More About Areas
I do believe that areas are always rectangular. If you make a selection with the control key down, each down-drag-up of the mouse represents an area. I’ve delved into this area (hah) before in the SelectTracker post. As indicated there, if you hold down Ctrl and click a cell five times you get a Selection with five Areas. Interestingly, Excel 2016 gives the unsuspecting user a bit of a hint that this is happening by making the cell a little darker with each click:

darkening Selection

Back to the Coding Process

At first, as so often happens, the VBA seemed fairly simple:

  1. Find the ActiveCell’s position within the overall Selection by looping through its Areas and through each Area’s cells.
  2. Figure out what the next (or previous) cell would be, accounting for moving from one Area to the next and hopping to the beginning of the next Area or looping back to the beginning of the whole Selection.

Then I started thinking about Selections with multiple Areas that intersect the ActiveCell. To deal with this I did two things needed to make the tabbing flow smoothly through overlapping Areas.:

  1. Created a global variable to track which of these areas was selected by the last Tab press.
  2. Created a short routine to figure out the “most recent” Area that intersects the ActiveCell

The Code
Here’s the code that identifies the Activecell’s position within the Selection’s Areas and Cells:

Private Sub SelectNextCellInSelection()

'This sub is called when the Tab key is pressed.
'The point is to be able to capture Tab key presses
'that occur within a Selection, thereby capturing movement of the Activecell.
Dim SelectionCellIndex As Long
Dim SelectionCell As Excel.Range
Dim SelectionArea As Excel.Range

For Each SelectionArea In Selection.Areas
    SelectionCellIndex = 0
    'Mod lets us cycle to the Area after we reach the last one
    SelectionAreaIndex = (SelectionAreaIndex Mod Selection.Areas.Count) + 1
    For Each SelectionCell In Selection.Areas(SelectionAreaIndex).Cells
        SelectionCellIndex = SelectionCellIndex + 1
        If SelectionCell.Address = ActiveCell.Address Then
            GoTo SelectNext
        End If
    Next SelectionCell
Next SelectionArea

SelectNext:
'Cycle to the next cell. If we're in the last one, we'll cycle to first.
SelectionCellIndex = (SelectionCellIndex Mod Selection.Areas(SelectionAreaIndex).Cells.Count) + 1
'If we're in the first cell must have gone to the next Area.
If SelectionCellIndex = 1 Then
    SelectionAreaIndex = (SelectionAreaIndex Mod Selection.Areas.Count) + 1
End If

Selection.Areas(SelectionAreaIndex).Cells(SelectionCellIndex).Activate
'Because it will get incremented next time round
SelectionAreaIndex = SelectionAreaIndex - 1
End Sub

The code above uses the Mod function to cycle back to the beginning of the next Area or of the entire Selection.

The code to cycle backwards was surpisingly more difficult. Mod didn’t work in reverse, For/Next doesn’t work in reverse, and the beginning number is the last number of the previous Area changes (not 1). So although the logic was the same, the coding was much trickier.

Putting this in a UserForm had the additional complication that the procedures assigned to a key using OnKey have to reside in a regular module. So my code has two very short routines that poke a property in the UserForm, effectively passing the action back into the form as soon as possible.

I also learned VBA’s AppActivate command which shifts the focus from the form to Excel proper. I do that at the end of the forms Activate procedure, since it’s a Viewer after all and doesn’t need the focus.

The ActiveCell Viewer
You may be wondering why you even need an ActiveCell viewer. Well, you probably don’t. But if you did, it might be to see what’s in cells with big blobs of text, or ones that are in hidden columns or rows. And its ability to view cell contents using different format strings might also be nice:

Viewer in Action

Download
Download the sample workbook and try it yourself!

MenuRighter Update Finished

MenuRighter Update Finished

A year or so ago I posted about updating MenuRighter, my free add-in for customizing Excel’s right-click menus. It’s done! You can go to the MenuRighter page for a download link and instructions. Or read on for some examples of what MenuRighter can do.

MenuRigher Customization Examples
Below I’ve modified the Row menu, with the default Excel 2016 version on the left and the modified version on the right. Copy, Cut, Paste and a few other buttons were removed and Freeze Panes is added to the top:

MenuRighter sample Row before

Post_0099_MenuRighter_sample_Row_after

Here’s the modified Row menu in use. Note that the button caption changes in context from “Freeze” to “Unfreeze”:

MenuRighter Row modification in action

Modified Cell Menu
Here’s my modified Cell right-click menu. It’s barely recognizable, so let me restate that this is the menu you get when you right-click in a cell. I’ve again deleted the Cut, Copy, Paste, Clear Contents and several other buttons. At the top I’ve added the menu for my personal addin, cleverly named “myBar.” Just one click added the whole structure to the Cell menu:

MenuRighter sample Cell

You can see that I’ve also added a whole bunch of filtering buttons. Two of the built-in ones are pulled up a level from the Cell>Filter menu, like “Filter by Selected Cell’s Value.” There’s also a couple for my own routines, like “Filter by All Selected Values.”

“Autofilter” is there so I can toggle filtering for whatever Table or range I’m in. (If you’re looking for this one, one its locations is Worksheet Menu Bar > Data > Filter > AutoFilter).

Two Other Examples

Here I’ve added a couple of my routines to the Ply menu. That’s the one you get by right-clicking a sheet tab:
MenuRighter sample Ply

And here’s the entire File menu added to the Cell menu. Everything at your fingertips!

Cell with File

Just kidding. I’d never do that.

New MenuRighter Page

Again, here’s the page with the download link and instructions for the new version. Please let me know what you think if you try it.

Getting Pivot Table Value Field Characteristics

Getting Pivot Table Value Field Characteristics

This post is about a bit of code that answered somebody’s Stack Overflow question, was fun to write, and taught me a few more things about the pivot table object model, which is my favorite object model. So neat, so tidy, so logical – just like pivot tables themselves.

What, you ask, do I mean by Value Field Characteristics? I mean the page, row and column fields and items that the value field is summing, counting or otherwise valuing. So in the picture below the selected value field has three row items: one each for Continent, Country and State.

value field

The Code

Here’s the code to print that same information to the Immediate window. Like the Excel tooltip in the picture it also lists the Value field name, e.g., Sum of Population, and its source field, e.g., Population. (This can be handy when you’ve modified the value field name to something like else, like “Residents.”):

Sub GetValueFieldStuff()
Dim pvtCell As Excel.PivotCell
Dim pvtTable As Excel.PivotTable
Dim pvtField As Excel.PivotField
Dim pvtItem As Excel.PivotItem
Dim pvtParentField As Excel.PivotField
Dim i As Long

On Error Resume Next
Set pvtCell = ActiveCell.PivotCell
If Err.Number <> 0 Then
    MsgBox "The cursor needs to be in a pivot table"
    Exit Sub
End If
On Error GoTo 0

If pvtCell.PivotCellType <> xlPivotCellValue Then
    MsgBox "The cursor needs to be in a Value field cell"
    Exit Sub
End If

Set pvtTable = pvtCell.PivotTable
For Each pvtField In pvtTable.PageFields
    i = 0
    For Each pvtItem In pvtField.PivotItems
        If pvtItem.Visible Then
            i = i + 1
            Debug.Print "PageField " & pvtField.Name & " - Pivot Item " & i & " is " & pvtItem.Name
        End If
    Next pvtItem
Next pvtField

Debug.Print "Value Field Name is " & pvtCell.PivotField.Name
Debug.Print "Value Field Source is " & pvtCell.PivotField.SourceName

For i = 1 To pvtCell.RowItems.Count
    Set pvtParentField = pvtCell.RowItems(i).Parent
    Debug.Print "Row Item " & i & " is " & pvtCell.RowItems(i).Name & ". It's parent Row Field is: " & pvtParentField.Name
Next i

For i = 1 To pvtCell.ColumnItems.Count
    Set pvtParentField = pvtCell.ColumnItems(i).Parent
    Debug.Print "Column Item " & i & " is " & pvtCell.ColumnItems(i).Name; ". It's parent Column Field is: " & pvtParentField.Name
Next i
End Sub

Before answering this question I didn’t know about the PivotCell.RowItems and PivotCell.ColumnItems properties. They’re pretty cool.

The person who posted this on Stack Overflow was looking to create an “actual” drilldown, which I think meant using the output to write a SQL query. You could modify the output of this routine to do so, as in this pseudocode:

SELECT * FROM qryContinentCountryState
WHERE pvtParentItem.Name = pvtCell.RowItems(i).Name
AND …

Alrighty then. Thanks for dropping by!

Regex Cell Searcher

Regex Cell Searcher

My data is are of course always perfectly formed, so should I ever need to do something as mundane as copy and paste one of them – a datum that is – into another application I would just select the entire cell and copy and paste it. I’d never need something like a Regex Cell Searcher, aka reg(Excel)lsearcher, to parse my datum, er data, no … datum. Whatever.

But say I did. Say I had wanted to select a cell and instantly have all the phone numbers in that cell plunked into a listbox.

And imagine I could type regexes really fast:

regex cell searcher in action

And let’s also say I wanted to pluck the area codes from the same cell using regex submatches:

submatches

And say – just daring to dream here – I wanted the first phone number in the listbox automatically copied to the Windows clipboard. Like below, where I click the cell, the matches are found, and the first one is ready to be pasted into a search engine:

regex copy into clipboard

The Regular Expression

Here’s the regex I came up with to check for a phone number, which I’m defining as three numbers, bracketed or not by parentheses, followed by a space, dash or period, followed by three numbers, etc.:

(?:(\(?\d{3}\)?) ?[-\.]?)?\d{3}[-\.]\d{4}

I can see some issues with it. Regexes are finicky things and accounting for all the possibilities is tricky.

Happily, I’m one of those people with a love of regular expressions. When I bought a book recently for the first time in perhaps 10 years, it was Mastering Regular Expressions.

The Code

Here’s the routine that fills the listbox:

Private Sub UpdateResults()
Dim collMatches As Collection
Dim OneMatch As VBScript_RegExp_55.Match
Dim i As Long
Dim j As Long

Me.lstMatches.Clear
Me.lstSubMatches.Clear
If IsRegexPatternValid(Me.txtPattern) And Me.txtPattern <> "" Then
    Set collMatches = GetRegexMatches(Me.txtInput, Me.txtPattern)
    lstMatches.Clear
    For i = 1 To collMatches.Count
        Set OneMatch = collMatches(i)
        lstMatches.AddItem OneMatch
        If OneMatch.SubMatches.Count > 0 Then
            For j = 1 To OneMatch.SubMatches.Count
                Me.lstSubMatches.AddItem OneMatch.SubMatches(j - 1)
            Next j
        End If
    Next i
End If
End Sub

And here’s the code that uses regular expressions to get the matches and submatches:

Function GetRegexMatches(InputString As String, SearchPattern As String, _
                         Optional boolIgnoreCase As Boolean = True, Optional boolGlobal As Boolean = True, Optional boolMultiline As Boolean = True, _
                         Optional UniqueMatches As Boolean = False) As Collection
Dim Regex As VBScript_RegExp_55.RegExp
Dim rgxMatch As VBScript_RegExp_55.Match
Dim rgxMatches As VBScript_RegExp_55.MatchCollection
Dim collMatches As Collection
Dim collUniqueMatches As Collection

Set Regex = New VBScript_RegExp_55.RegExp
With Regex
    .Pattern = SearchPattern
    .IgnoreCase = boolIgnoreCase
    'Find all matches, not just the first
    .Global = boolGlobal
    '^ and $ work per-line, not just at begin and end of file
    .MultiLine = boolMultiline
    Set collMatches = New Collection
    Set collUniqueMatches = New Collection
    If .test(InputString) Then
        'if matches, create a collection of them
        Set rgxMatches = .Execute(InputString)
        For Each rgxMatch In rgxMatches
            collMatches.Add rgxMatch
            On Error Resume Next
            collUniqueMatches.Add rgxMatch, rgxMatch
            On Error GoTo 0
        Next rgxMatch
    End If
End With



In addition to the features mentioned above, you can click on any item in the Match or SubMatch listboxes and that item will be copied to the clipboard. The form uses an Application class to track selections across all workbooks and is resizable using my form resizing code.

Regex in Excel Proper?

For those of you visiting the Excel User Voice site, where you can suggest and vote on future features in Excel, you may have noticed a fairly popular suggestion would add regex capabilities to Excel.

Download

Here’s a workbook with the form and the code.

Close Workbook While Writing Over It

Close Workbook While Writing Over It

I appreciate that, when trying to copy over an open file, File Explorer gives me a chance to close the file and come back to resume the copy. It used to just stop, as I remember, but now it’s very nice:

folder is open warning

I’m not sure why the message says that a “folder” is open – I’m only trying to copy one file. That’s okay though, it’s clear enough what the message means (especially if you read it quickly). So, I just go into Excel, close the workbook and then go back to File Explorer and hit the “Try Again” button. I thought it would be helpful, or at least fun, to have a complementary function in Excel – a function that closes the workbook but allows me to immediately re-open it after finishing the copy

This is useful when saving to Excel from another program, like Crystal Reports, that exports to a workbook. Generally, I do the export, look at the output workbook, see something I want to change, go back into Crystal to fiddle, and export again*. Of course I can’t do the export if the workbook is still open, so I close it (if I remember) and then re-open it after the export. This requires using Excel’s Recent Files list, and if you read my last post you know I’m not a big fan.

So my most recent addition to my personal addin is a little routine that closes the active workbook and pops up a message box that “holds its place.” That way when I come back from saving over the just-closed file, I can re-open it with the click of a button:

close and hold
Here’s the code:

Sub CloseWbAndHold()
Dim WorkbookToClose As String

If ActiveWorkbook Is Nothing Then
    MsgBox "No active workbook."
    Exit Sub
End If
If ActiveWorkbook.Path = "" Then
    MsgBox "This workbook has no path."
    Exit Sub
End If

WorkbookToClose = ActiveWorkbook.FullName
ActiveWorkbook.Close False

If MsgBox("Re-open " & vbCrLf & WorkbookToClose & "?", vbYesNo + vbQuestion, "Re-open?") _
  = VbMsgBoxResult.vbYes Then
    Workbooks.Open WorkbookToClose
End If
End Sub

Note that the code closes the workbook without prompting to save, since I’m only planning to use it when I’m about to write over the workbook anyways.

And if I decide I want something even simpler, maybe I’ll just go with this:

Sub ReOpenLastFile()
If Application.RecentFiles.Count > 0 Then
    Workbooks.Open Application.RecentFiles(1)
End If
End Sub


* I’m happy to say that we use Crystal Reports mostly as a presentation layer for SQL, so I don’t often have to deal with formulas and the like in it.

Remove Filters From Other Columns

Remove Filters From Other Columns

Here’s another in what’s turning out to be a series of posts on AutoFiltering. This time it’s a bit of code to remove filters from all the columns except those that are part of the current selection. The idea is kind of like “Close Other Tabs” in Fireox or Notepad++. It works for Tables and plain old filtered ranges. I wrote it the other day while working on a mile-wide list with various fancy filters, most of which I wanted to get rid of.

It’s not much code, and hopefully it’s self-explanatory. (If not, you know where to find me.)

Sub ClearFiltersFromOtherColumns()
Dim i As Long
Dim AutoFltr As Excel.AutoFilter

If ActiveSheet Is Nothing Then
    MsgBox "No active worksheet."
    Exit Sub
End If
'Determine the range with the filter depending on whether it's a Table or not
If Not ActiveCell.ListObject Is Nothing Then
    Set AutoFltr = ActiveCell.ListObject.AutoFilter
Else
    Set AutoFltr = ActiveCell.Parent.AutoFilter
End If
If AutoFltr Is Nothing Then
    MsgBox "The selection is not within filtered table or range"
    Exit Sub
End If
If Union(Selection, AutoFltr.Range).Address <> AutoFltr.Range.Address Then
    MsgBox "Please make sure all cells are within the same table or filtered area."
    Exit Sub
End If

For i = 1 To AutoFltr.Filters.Count
    If AutoFltr.Filters(i).On And _
       (Intersect(Selection.EntireColumn, AutoFltr.Range.Columns(i)) Is Nothing) Then
        AutoFltr.Range.AutoFilter Field:=i
    End If
Next i
End Sub

The part I like is how it narrows down to a aingle AutoFilter object regardless of whether you’re working with a ListObject or just a filtered range. I’m not sure I knew there was such an object until I read Mike Alexander’s post on A Better Way to Copy Filtered Rows Using VBA.

Get Word Instance Functions

Get Word Instance Functions

Submitted for your approval. Three functions. Functions to do a simple job. Do it well. Or not. You be the judge.

Yes, I’m trying something new and hoping to drag you along. Don’t worry, it’s just a poll.

A poll about what?
I haven’t automated Word for quite a bit and so, to ease into it, I noodled around with all-purpose functions to find or create a Word instance.

Function Specs
This function, as I imagine it, would have one option with three choices. Or is that one choice with three options?

1. Return only an existing instance of Word. If no instances are open, return nothing.
2. Return an existing instance of Word. If none exists, create a new one.
3. Create a new instance of Word whether or not one’s already open.

That’s not what I want you to vote on. I think we can all agree there’s a time and place for each of these options.

What I want to know is which of the following functions you like best. They all do the same thing, with slightly different approaches.

Function #1 – Enums: I love ’em, or at least the idea of them. In this case we can use their bitwise ANDing capability to shorten, and perhaps obfuscate.

Public Enum WordInstanceType
    ExistingInstance = 1
    NewInstance = 2
End Enum

Function GetWordInstance(InstanceType As WordInstanceType) As Object
Dim wd As Object

If InstanceType And ExistingInstance Then
    On Error Resume Next
    Set wd = GetObject(, "Word.Application")
    On Error GoTo 0
End If
'If wd is nothing now it's either because there were no existing instances
'and/or we asked for New
If (InstanceType And NewInstance) And wd Is Nothing Then
    Set wd = CreateObject("Word.Application")
End If
Set GetWordInstance = wd
End Function

Function #2 – FallThrough: It’s got an ugly pattern, but it matches the way I think about it. No enum, so you’d have to look at the function to figure out what strings it recognizes. That’s pretty ugly too, so maybe you’d want to change it to an enum.

Function GetWordInstance2(InstanceType As String) As Object
Dim wd As Object

If InstanceType = "ExistingInstance" Or InstanceType = "ExistingThenNew" Then
    On Error Resume Next
    Set wd = GetObject(, "Word.Application")
    On Error GoTo 0
    'If we only want Existing, then we either got it or not
    If InstanceType = "ExistingInstance" Then
        Set GetWordInstance2 = wd
        Exit Function
    End If
End If
'If wd is nothing now it's either because
'we specified ExistingThenNew and there were no existing instances
'or we specified NewInstance
If wd Is Nothing Then
    Set wd = CreateObject("Word.Application")
End If
Set GetWordInstance2 = wd
End Function

Function #3 – Plodding Boy, I’m really selling these, huh? Like #2, no enum. It doesn’t worry about duplicated code, just lays out the steps for each option. A simple function for a simple man.

Function GetWordInstance3(InstanceType As String) As Object
Dim wd As Object

If InstanceType = "ExistingInstance" Then
    On Error Resume Next
    Set wd = GetObject(, "Word.Application")
    On Error GoTo 0
ElseIf InstanceType = "ExistingThenNew" Then
    On Error Resume Next
    Set wd = GetObject(, "Word.Application")
    On Error GoTo 0
    If wd Is Nothing Then
        Set wd = CreateObject("Word.Application")
    End If
ElseIf InstanceType = "NewInstance" Then
    Set wd = CreateObject("Word.Application")
End If

Set GetWordInstance3 = wd
End Function

So, okay, the poll. Which function do you prefer?

View Results

Loading ... Loading ...