Excel VBA -- Named Range Automation

A few weeks ago, I was working with an Excel workbook that had 18 sheets that were similar in structure. Half the sheets had names L1_1, L1_2, … L1_9; the other half, R1_1, R1_2, … R1_9. They contained dimensions of structures on the left and right of a substrate.

I wanted to display a summary of a few averages from each sheet on a new sheet. I knew this would involve the tedious process of selecting a range of cells for each average, so I decided I would write VBA code to create a named range for each group of cells that I wanted averaged.

I turned on the Macro Recorder and then manually created the range so I could get some idea of what object and property to set. It recorded this:

    ActiveWorkbook.Names.Add "PGC_1”, "=L1_1!$D$3:$D$84"

This told me that the Add method of the Names collection would require the Name and the Address of the desired named range.  And so I wrote this subroutine:

Sub CreateNamedRanges()
Dim objN As Name
Dim i As Integer, s As String

For i = 1 To 9

s = CStr(i)

ActiveWorkbook.Names.Add "PGC_" & s, "=L1_" & s & "!$D$3:$D$84"

ActiveWorkbook.Names.Add "PGL_" & s, "=L1_" & s & "!$D$190:$D$376"

ActiveWorkbook.Names.Add "PTL_" & s, "=L1_" & s & "!$D$101:$D$173"

ActiveWorkbook.Names.Add "PGR_" & s, "=R1_" & s & "!$D$190:$D$376"

ActiveWorkbook.Names.Add "PTR_" & s, "=R1_" & s & "!$D$101:$D$173"

Next i

For Each objN In ActiveWorkbook.Names

Debug.Print objN.Name, objN.RefersTo

Next

End Sub

But the code crashed on the fourth Add method; it complained about an invalid address.

It didn’t make sense. I looked carefully at the fourth Add method. There were no illegal characters or trailing whitespace or other pitfalls. I found references to the error online, but none of the content pertained to what I was working on.

Eventually it dawned on me that perhaps Excel was confusing the “=R1_” & s as an R1C1 style address. Perhaps I needed to make sure it knew that “=R1_” & s was a sheet name. And so I placed two single quotes in each address: one right after the equal sign, and one right before the exclamation mark, like this: "=’R1_" & s & "’!$D$190:$D$376"

After this correction, the code ran quickly.

Get Path to Current LibreOffice Spreadsheet

There are two comments related to the previous post:

1. The blood draw wasn’t scheduled for the next morning. It was for the following morning! What a dummy I am!
2. The code that I use in LibreOffice Calc to return the Current Working Directory can be found below. I call it with this worksheet function as an argument: CELL("FILENAME",$A$1).  Please note that the module in which this resides has the following statement at the top: Option VBASupport 1

Function LG_GetPath(s As String) As String

' 2019-02-26 LG  Created, mostly to derive Current Working Directory
	Dim sTemp As String
	Dim i As Long, j As Long
	' MsgBox "Contents of s: " & s
	If IsNull(s) Then
    	LG_GetPath = "ERROR"
    Else
    	sTemp = CStr(s)
    	i = InStr(s, "///") + 3
    	j = InStrRev(s, "/")
    	j = j - i
    	If j > 0 Then
    		sTemp = Mid(s, i, j) & "/"
    		LG_GetPath = sTemp
    	Else
    		LG_GetPath = "ERROR"
    	EndIf
    EndIf	
End Function ' LG_GetPath

Count Selected Items in Outlook

The modern Outlook status bar no longer shows the number of selected items. So some folks suggest that you select items and simply press Enter in order to trick Outlook into thinking you want to open all of them. And if you have more than four items selected, Outlook supposedly will pop up a warning that opening X number of items could take a long time.

But what happens if you accidentally agree to open them, or if the instance of Outlook doesn’t warn you, as in my case? Then you’ve wasted time opening emails and failed to get your answer.

No, it’s never a good idea to rely on an operation’s side effect; it could be eliminated in the next version!

What I do instead is surprisingly simple.  I just call the Count property of Selection.  This returns the number of selected items. I call the property with a message box that’s wrapped in a subroutine, which I link to a button on the Actions Menu.

This is all you need:

Sub CountItems()

MsgBox ActiveExplorer.Selection.Count & " items are selected", vbOKOnly, "CountItems() Message"

End Sub

It would be nice if there were an easy way to add a link to this on my shortcut menu.

View Internet Header of an Email Message in Modern Outlook Client

One should always examine the Internet Header of a suspicious email.  Yet, when Microsoft upgraded Outlook, this has become more difficult than just right-clicking and choosing View Header.  Instead, you'll first have to open the message (a cringe-worthy action), and then navigate to File and Properties as described here.

I can never remember the procedure.  Besides, I want to see the header before I open the message!

So I wrote a macro that displays the beginning of the header in a message box.  Then it offers the choice of whether to copy the header content to the clipboard, which would allow for pasting into a new message to the IT department (for example).

Then I added a button to Quick Launch and bound it to the macro.  The upshot is that I can select the message in my Inbox list of messages, press the button, and see the header!

Here's the code, which I couldn't have completed without the help of the Slipstick code sample.  Please be careful of unintended wrapping of code, particularly for the value of PR_TRANSPORT_MESSAGE_HEADERS constant!

Sub HeaderReview()
' Copy Message Header contents of selected Mail Item to the Windows Clipboard.
' See: https://www.slipstick.com/developer/code-samples/outlooks-internet-headers/
' 2020-01-23 LG  Created from CopyToClipboard dated 12/13/04

Dim objCB As New DataObject ' Clipboard object
Dim ol As New Outlook.Application
Dim oe As Outlook.Explorer
Dim mi As Outlook.MailItem
Dim strMH As String ' Mail Header

Set oe = ol.ActiveExplorer

If oe.CurrentFolder.DefaultItemType = olMailItem Then
    Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
    Dim olkPA As Outlook.PropertyAccessor
    Dim i As Integer
    Set mi = oe.Selection.Item(1)
    Set olkPA = mi.PropertyAccessor
    strMH = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
    Debug.Print strMH
    i = MsgBox(strMH, vbYesNo, "Copy Message Header to Clipboard?")
    Select Case i
        Case vbYes
            objCB.SetText strMH
            objCB.PutInClipboard
    End Select
Else
    MsgBox "Sorry, HeaderReview() supports only Mail items at this time.", _
    , "HeaderReview() Help"
    
End If

End Sub

Quickly Delete Many Excel Worksheets

In "Reverse the Order of Worksheets in an Excel Workbook" I show a VBA module that I wrote in order to reverse the order of several dozen worksheets in an Excel file.

Each tab contains a summary of data for a week.  After a few years, I had amassed over 100 worksheets.  So I decided I would split the workbook; each one would contain only one year's worth of data.  The workbook for 2018 would have only the 2018 worksheets; 2017 workbook, the 2017 worksheets; etc.

I copied the massive workbook to a 2018 workbook, from which I'd delete all but the 2018 worksheets.  Ditto for 2017, 2016, and, oh yes, 2019, as well.

Unfortunately I found this to be exceedingly tedious.  There didn't seem to be a way to delete multiple worksheets quickly and without many keystrokes and/or mouse clicks.  At best, I was able to select the six tabs that could be displayed at one time by clicking the left-most tab and shift-clicking the right-most tab.  Then I could right-click and delete the selected tabs.  But I'd have to do that about 20 times for each workbook!

So instead, I wrote the following VBA module to do it effortlessly.  Note that each worksheet is named with the date in YYYY-MM-DD format.  (So the worksheet for today would be named 2019-10-17. ) This module was used to delete all the 2019 worksheets.  Rather than write a nested loop to cycle through multiple years, I decided to change the year in the code manually.

  Sub DeleteNewWorksheets()
      ' 2019-03-24 TG  Created to clean up status records
      Dim Sheet As Worksheet
      Dim Book As Workbook
      Dim n As String
      Dim alerts As Boolean
      Dim i As Integer

      alerts = Application.DisplayAlerts
      Application.DisplayAlerts = False
      Set Book = ActiveWorkbook

      i = 0
      For Each Sheet In Book.Sheets
          n = Left(Sheet.Name, 4)
          If n = "2019" Then
              Debug.Print "Deleted " & Sheet.Name
              Sheet.Delete
              i = i + 1
          End If
      Next

      Application.DisplayAlerts = alerts
      MsgBox "Deleted " & i & " sheets.", vbInformation, "DeleteOldWorksheets Notification"
  End Sub

How to Use Excel Pivot Tables to Summarize Continuous Data

Suppose you have a set of data points that represent some quantity in a volume.  It could be temperature in a solid, for example.  How can you use a Pivot Table find the average temperature in a region on the solid’s surface?

Well, if you’re lucky, the region is rectangular, bounded by some Xmin and Xmax and Ymin and Ymax.  Then you can use the built-in Label Filters.

I created a set of data for this article with -20<=X<=20, -20<=Y<=20, -20<=Z<=20.  The temperature is a function of X,Y,Z using the (arbitrary) formula =2.5*X+0.25*Y^2+2.5*SIN(Z).

First, set up the Pivot Table and chose the option to Allow multiple filters per field.

In the screenshots below, we define a Region with Label Filters in the PivotTable Rows within X=[-2,8] and Y=[5,7].  The function is not dependent on the Z coordinate – we’ll use a Page Filter to constrain Z to 0.  As can be seen in the status line of the fourth screenshot below, the average temperature in that region is 16.67 degrees C.

But suppose the region is more complicated than a rectangle, or you want to summarize multiple regions?

You can define a function in VBA to “discretize” the data, as shown in the code sample, below.

Option Explicit

Function Region(rngX As Range, rngY As Range, rngZ As Range) As String

Const regA_Xmin = -2#: Const regA_Xmax = 8#

Const regA_Ymin = 5#: Const regA_Ymax = 7#

Const regB_Xmin = -6#: Const regB_Xmax = -3#

Const regB_Ymin = 5#: Const regB_Ymax = 7#

Const regC_Xmin = -2#: Const regC_Xmax = 8#

Const regC_Ymin = -5#: Const regC_Ymax = -3#

Const regD_Xmin = 9#: Const regD_Xmax = 12#

Const regD_Ymin = 5#: Const regD_Ymax = 7#

Const regE_Xmin = 16#: Const regE_Xmax = 18#

Const regE_Ymin = -15#: Const regE_Ymax = -7#

Dim x As Double, y As Double, z As Double

x = rngX.Value: y = rngY.Value: z = rngZ.Value

If x >= regA_Xmin And x <= regA_Xmax And _

   y >= regA_Ymin And y <= regA_Ymax Then

        Region = "Region A"

ElseIf x >= regB_Xmin And x <= regB_Xmax And _

       y >= regB_Ymin And y <= regB_Ymax Then

        Region = "Region B"

ElseIf x >= regC_Xmin And x <= regC_Xmax And _

       y >= regC_Ymin And y <= regC_Ymax Then

        Region = "Region C"

ElseIf x >= regD_Xmin And x <= regD_Xmax And _

       y >= regD_Ymin And y <= regD_Ymax Then

        Region = "Region D"

Else

    Region = "NA"

End If

End Function

The function accepts three Range type parameters, each of which are intended to be the address of a single cell.  It returns one of five strings: Region A, Region B, Region C, Region D, NA.

The first four constants that are defined in the first two lines are minimum and maximum X and Y coordinates for the region that were defined in the previous example with Label Filters.  So the string “Region A” is returned if X and Y are within those X-Y intervals.

When we type in cell E2 =Region(A2, B2, C2) and then fill down, Excel calls the function for each of the cells that the formula occupies and then puts the result in that cell.  It can take several seconds for all the cells to be populated, even with an i5 processor.  And the calculation can increase the drain on the battery if you’re doing this unplugged / on the road.

But when it’s complete, you can set up your Pivot Table with the regions in the row.  The average of the temperature values for Region A is shown in cell B5 below as 16.67.

Where Should You Stick Your Function?

Let's say you need to create a VBA function to use in a spreadsheet. Where do you put it? Quick answer, put it in a module.

In Excel, press Alt-F11, Ctrl-R (to set focus to the Project Explorer). Right click on VBAProject (xls_name), where xls_name in the file name of your workbook. Select Insert Module.

A blank code window should appear and the cursor should be positioned in it.  This is "Module1" where you can enter your code, such as...

Option Explicit
Function FortyTwo(r As Range)
If r.Value = 42 Then
    FortyTwo = "Forty-Two"
Else
    FortyTwo = r.Value
End If
End Function

If you enter 1, apple, and =6*7 in cells A1, A2 A3, here's what you get as output if you enter =FortyTwo(A1) in cell B1 and drag down to B3:

Of course, if A3 contained =6*9 you should also get Forty-Two, but that's a programming challenge for another day.

Reverse the Order of Worksheets in an Excel Workbook

Today I found myself wanting to reverse the order of sheet tabs in an Excel file.  The VBA code snippet below does just that.

Sub Worksheet_Reverse_Order()
Dim MySheet As Worksheet
Dim i As Integer

For Each MySheet In Worksheets
Debug.Print MySheet.Index, MySheet.Name
Next

For i = 2 To Worksheets.Count
Set MySheet = Worksheets(i)
MySheet.Move before:=Worksheets(1)
Next i

For Each MySheet In Worksheets
Debug.Print MySheet.Index, MySheet.Name
Next

End Sub


Background...
I had been maintaining weekly status updates as Excel spreadsheets, all grouped into one XLS document.  Each week I'd add a new sheet to the right of the previous week's worksheet tab.

But due to a change in workflow, I now have to copy the new sheet into that workbook rather than create it in the workbook.  In order to keep placing the new sheet after all the others, it's necessary to scroll to the end of the list of sheets and select "(move to end)".

"It would be so much easier if the sheets were in reverse order," I sighed to myself.  The thought of dragging them into reverse order manually was, well, unthinkable.  And thus this VBA macro was born.

Execute Text in MS Word Using the System Shell

I was writing a tutorial in Microsoft Word that describes commands that the reader is supposed to enter at the command prompt.  I thought it would be neat if I could run those commands from within Word to validate them as I entered them.

And so I came up with a surprisingly simple VBA subroutine that sends selected text to the shell.  It is quoted, below.  The code should be placed into a module in Normal.dot.

Note that I invoke two statements in the Shell.  They are separated by the double ampersands.  I combine them into a single string (strCmd) that I pass to the shell.

The first statement is to change to the current working directory, which I assume is the same directory that the Word document resides in.  This isn't fool proof, however.  One failure mode would be if someone were to start Word and create a new document without saving it to the hard drive before calling the routine.  Another failure mode would be if the Word document were to reside on a remote share through a UNC path, such as \\FileServer\ShareName\tutorial.doc -- it's not possible to CD into a UNC path.

The second statement is merely the selected text.

Also note that strCmd  is preceded by the Win32 command prompt CMD.EXE.  The "/D" switch makes sure that no "AutoRun" commands get executed.  The "/C" switch terminates CMD after the command is finished executing.  CMD is included because Shell isn't able to find DOS commands such as CD.

Sorry for the small font on this source code, but I wanted to ensure it wouldn't wrap.

Sub InvokeWithShell()
' Executes the selected text to using the shell
' 2014-06-09 LudditeGeek Created
    Dim strCmd As String
   
    If Selection.Characters.Count <= 1 Then
        MsgBox "Nothing Selected!", vbExclamation, "Invoke With Shell Macro Message"
    ElseIf Selection.Paragraphs.Count > 1 Then
        MsgBox "Multiple Lines Selected!", vbExclamation, "Invoke With Shell Macro Message"
    Else
        strCmd = Selection.Text
        Debug.Print "Invoking " & strCmd
        strCmd = "cd " & ActiveDocument.Path & "\ && " & strCmd
        Shell "cmd /D /C " & strCmd
    End If
   
End Sub