Text handling functions
There are three text functions, which extend the basic functionality of Excel's Left, Right and Mid functions.
- Extended LEFT function
- Extended RIGHT function
- Extended MID function
- Download the code for all 3 text functions
1. Extended LEFT function
This user defined function extends Excel's Left string function.
The additional functionality is to get all the text from the start (left-hand side) of the text string up to a delimiter. The delimiter
can be any character or group of characters, and the function allows the Nth instance of the delimiter to be used as the end point of
the text. If the instance value is negative the delimiter instance is counted from the end of the string.
For example, if the text in cell A1 is "C:\Documents and Settings\All Users\Documents\My Music\Music.wma"
To get the full directory path, use =XtndLeft(A1,"\",- 1)
,
which returns "C:\Documents and Settings\All Users\Documents\My Music"
This is valuable when you don't know how many sub-directories deep the file path is.
Using =XtndLeft(A1,"\",2) would return "C:\Documents and Settings"
To use a special character as a delimiter, such as a Tab, enter $$n, where n is the character code, n=9 for Tab.
Add the following code to a module –See How to add a function to your copy of Excel
Function XtndLeft(TextRef As Range, Delim1 As String, Optional Delim1Inst As Integer = 1) As Variant
'**************************************************************
'Extended Left Function
'© Humar Consulting Inc.
'Version 1.1 May 2008
'**************************************************************
Dim TxtStrt As Integer
Dim TxtFnsh As Integer
Dim TxtLen As Integer
Dim n As Integer
Dim Inst As Integer
Dim LocalText As String
Dim SpChar As String
'**************************************************************
'Get length of text & a local copy of the text
LocalText = TextRef.Text
TxtLen = Len(LocalText)
'**************************************************************
'Look for special characters in delimiter
If Left(Delim1, 2) = "$$" Then
SpChar = Right(Delim1, Len(Delim1) - 2)
Delim1 = Chr(CInt(SpChar))
End If
'**************************************************************
'Test for valid instance of delimiter
Inst = 0
For n = 1 To Abs(Delim1Inst)
Inst = InStr(Inst + 1, LocalText, Delim1, vbTextCompare)
If Inst = 0 Then
XtndLeft = CVErr(xlErrNA)
GoTo ErrEnd
End If
Next
'**************************************************************
'Find end position
If Delim1Inst > 0 Then
'Delimiter counted from start of text
TxtFnsh = 1
For n = 1 To Delim1Inst
TxtFnsh = InStr(TxtFnsh, LocalText, Delim1, 0)
TxtFnsh = TxtFnsh + 1
Next
TxtFnsh = TxtFnsh - 1
Else
'Delimiter counted from end of text
TxtFnsh = TxtLen
For n = 1 To -Delim1Inst
TxtFnsh = InStrRev(LocalText, Delim1, TxtFnsh)
TxtFnsh = TxtFnsh - 1
Next
TxtFnsh = TxtFnsh + 1
End If
'**************************************************************
'Now get the text required
XtndLeft = Left(LocalText, TxtFnsh - 1)
Exit Function
ErrEnd:
End Function
2. Extended RIGHT function
This user defined function extends the Right string function.
The additional functionality is to get all the text from a specified delimiter up to the end (Right-hand side) of the text string.
The delimiter can be any character or group of characters and the function allows the Nth instance of the delimiter to be used as
the start point of the text.
If the instance value is negative the delimiter instance is counted from the end of the string.
For example if the text in cell A1 is "C:\Documents and Settings\All Users\Documents\My Music\Music.wma", To get the filename only,
use =XtndRight(A1,"\",- 1), which returns "Music.wma"
Using =XtndRight(A1,"\",1) would return "Documents and Settings\All Users\Documents\My Music\Music.wma"
In addition, the function can use special and non-printing characters as delimiters. The delimiter is entered as $$n, where n is the
character code. In the following example, the formula used is: =XtndRight(I13,"$$10",1). The character code 10 is the line feed
character which is used by Excel to force text in a cell onto a new line, (entered in a cell using Alt + Enter).
In the cell on the left, 2006 is separated from the text "Special Projects" by a line feed character. The cell on the right
contains the extended right formula, and returns the text 2006.
Add the following code to a module –See How to add a function to your copy of Excel
Function XtndRight(TextRef As Range, Delim1 As String, Optional Delim1Inst As Integer = 1) As Variant
'**************************************************************
'Extended Right Function
'© Humar Consulting Inc.
'Version 1.1 May 2008
'**************************************************************
Dim TxtStrt As Integer
Dim TxtFnsh As Integer
Dim TxtLen As Integer
Dim Inst1Len As Integer
Dim n As Integer
Dim Inst As Integer
Dim LocalText As String
Dim SpChar As String
'**************************************************************
'Get length of text & text
LocalText = TextRef.Text
TxtLen = Len(LocalText)
'**************************************************************
'Look for special characters in delimiter
If Left(Delim1, 2) = "$$" Then
SpChar = Right(Delim1, Len(Delim1) - 2)
Delim1 = Chr(CInt(SpChar))
End If
'**************************************************************
'Test for valid instance of delimiter
Inst = 0
For n = 1 To Abs(Delim1Inst)
Inst = InStr(Inst + 1, LocalText, Delim1, vbTextCompare)
If Inst = 0 Then
XtndRight = CVErr(xlErrNA)
GoTo ErrEnd
End If
Next
'**************************************************************
'Find start position
If Delim1Inst > 0 Then
'Delimiter counted from start of text
TxtStrt = 1 'variable for start position of search
For n = 1 To Delim1Inst
TxtStrt = InStr(TxtStrt, LocalText, Delim1, 0)
TxtStrt = TxtStrt + 1
Next
TxtStrt = TxtStrt - 1
Else
'Delimiter counted from end of text
TxtStrt = TxtLen 'variable for start position of search
For n = 1 To -Delim1Inst
TxtStrt = InStrRev(LocalText, Delim1, TxtStrt)
TxtStrt = TxtStrt - 1
Next
TxtStrt = TxtStrt + 1
End If
'Get length of delimiter to adjust for start position of text
TxtStrt = TxtStrt + Len(Delim1) - 1
'**************************************************************
'Now get the text required
XtndRight = Right(LocalText, TxtLen - TxtStrt)
Exit Function
'
'Errors exit here
ErrEnd:
End Function
3. Extended MID function
This user defined function extends Excel's Mid string function.
The additional functionality is to extract all the text between specified delimiters.
The delimiters can be any character or group of characters. The two delimiters can be the same or different, and the function
allows the Nth instance of either delimiter to be used. If the instance value of either delimiter is negative the delimiter
instance is counted from the end of the string.
For example if the text is : "Item # 10: Apples (boxed) Unit qty 50"
To get the item description, "Apples (boxed)", make the first delimiter a space " " and the instance = 3, i.e., start after
the third space. The second delimiter is also a space " " and the instance is 5.
If the text was in Cell A1 the formula would be =XtndMid(A1," ",3," ",5)
If there are a variable number of spaces in the text you want to extract, for instance the next item is: "Item # 11: Mixed Nuts
(boxed) Unit qty 12", use -3 for the instance number of the second delimiter, and the count is backwards from the end of the text.
If the text was in Cell A2 the formula would be =XtndMid(A2," ",3," ",–3).
The result is "Mixed Nuts (boxed)".
An alternative and in these examples, more robust version is to extract between the first ":" and the word "Unit". The formula is:
=XtndMid(A2,":",1,"Unit",- 1).
You could eliminate the leading space returned by this formula by making the first delimiter": ", alternatively, wrap the
formula in Excel's Trim function, so that the result is the same whether or not there were spaces between ":" and the description.
The formula would be =Trim(XtndMid(A2,":",1,"Unit",- 1)).
The second delimiter is optional, and if not given, defaults to the first delimiter.
The instance numbers are optional, and if not given, default to 1 and 2 respectively if both delimiters are the same. If the two
delimiters are different, then they both default to the first instance of each one.
If Cell A3 contains "Colors:Red:Green:Blue", and you want to extract the second color, the formula is =XtndMid(A3,":"). This
defaults to first and second delimiters ":" and the 1st and 2nd instances of ":". The result is "Red".
In addition, the function can use special and non-printing characters as delimiters. The delimiter is entered as $$n, where n is the
character code. One or both delimiters can use the $$n format. If $$n (e.g., $$10) is used for the first delimiter, and only one delimiter
is entered in the formula, the second delimiter will default to the special character code entered for the first delimiter.
Add the following code to a module –See How to add a function to your copy of Excel
Public Function XtndMid(TextRef As Range, Delim1 As String, Optional Delim1Inst As Integer = 1, Optional Delim2 As String, Optional Delim2Inst As Integer) As Variant
'**************************************************************
'Extended Mid function
'© Humar Consulting
'Version 1.1 May 2008
'**************************************************************
Dim TxtStrt As Integer
Dim TxtFnsh As Integer
Dim TxtLen As Integer
Dim Inst As Integer
Dim SpChar As String
Dim LocalText As String
Dim n As Integer
'**************************************************************
'If second delimiter not given, then copy it from first delimiter
If IsError(Delim2) Then Delim2 = Delim1
If Delim2 = "" Then Delim2 = Delim1
'**************************************************************
'If second Delimiter Instances not given, use default
If IsError(Delim2Inst) Or Delim2Inst = 0 Then
If Delim2 = Delim1 Then
Delim2Inst = Delim2Inst + 1
Else
Delim2Inst = 1
End If
End If
'**************************************************************
'Get length of text & a local copy of the text
LocalText = TextRef.Text
TxtLen = Len(LocalText)
'**************************************************************
'Look for special characters in delimiter 1
If Left(Delim1, 2) = "$$" Then
SpChar = Right(Delim1, Len(Delim1) - 2)
Delim1 = Chr(CInt(SpChar))
End If
'**************************************************************
'Look for special characters in delimiter 2
If Left(Delim2, 2) = "$$" Then
SpChar = Right(Delim2, Len(Delim2) - 2)
Delim2 = Chr(CInt(SpChar))
End If
'**************************************************************
'Test for valid instance of delimiter 1
Inst = 0
For n = 1 To Abs(Delim1Inst)
Inst = InStr(Inst + 1, LocalText, Delim1, vbTextCompare)
If Inst = 0 Then
XtndMid = CVErr(xlErrNA)
GoTo ErrEnd
End If
Next
'**************************************************************
'Test for valid instance of delimiter 2
Inst = 0
For n = 1 To Abs(Delim2Inst)
Inst = InStr(Inst + 1, LocalText, Delim2, vbTextCompare)
If Inst = 0 Then
XtndMid = CVErr(xlErrNA)
GoTo ErrEnd
End If
Next
'**************************************************************
'If Delim1 is the same as Delim2, test that the second instance comes after the first
If Delim1 = Delim2 Then
'get number of instances of delimiter
Inst = 0
For n = 1 To TxtLen
If Mid(LocalText, n, Len(Delim1)) = Delim1 Then Inst = Inst + 1
Next
'as either delimiter can be positive or negative there are 4 possible tests
If Delim1Inst < 0 And Delim2Inst < 0 Then
If Delim2Inst <= Delim1Inst Then
XtndMid = CVErr(xlErrValue)
GoTo ErrEnd
End If
End If
If Delim1Inst < 0 And Delim2Inst > 0 Then
If Abs(Delim1Inst) + Delim2Inst > Inst Then
XtndMid = CVErr(xlErrValue)
GoTo ErrEnd
End If
End If
If Delim1Inst > 0 And Delim2Inst > 0 Then
If Delim2Inst <= Delim1Inst Then
XtndMid = CVErr(xlErrValue)
GoTo ErrEnd
End If
End If
If Delim1Inst > 0 And Delim2Inst < 0 Then
If Delim1Inst + Abs(Delim2Inst) > Inst Then
XtndMid = CVErr(xlErrValue)
GoTo ErrEnd
End If
End If
End If
'**************************************************************
'Find start position
If Delim1Inst > 0 Then
'Delimiter counted from start of text
TxtStrt = 1 'variable for start position of search
For n = 1 To Delim1Inst
TxtStrt = InStr(TxtStrt, LocalText, Delim1, 0)
TxtStrt = TxtStrt + 1
Next
TxtStrt = TxtStrt - 1
Else
'Delimiter counted from end of text
TxtStrt = TxtLen 'variable for start position of search
For n = 1 To -Delim1Inst
TxtStrt = InStrRev(LocalText, Delim1, TxtStrt)
TxtStrt = TxtStrt - 1
Next
TxtStrt = TxtStrt + 1
End If
'Get length of delimiter to adjust for start position of text
TxtStrt = TxtStrt + Len(Delim1)
'**************************************************************
'Find end position
If Delim2Inst > 0 Then
'Delimiter counted from start of text
TxtFnsh = 1 'variable for start position of search
For n = 1 To Delim2Inst
TxtFnsh = InStr(TxtFnsh, LocalText, Delim2, 0)
TxtFnsh = TxtFnsh + 1
Next
TxtFnsh = TxtFnsh - 1
Else
'Delimiter counted from end of text
TxtFnsh = TxtLen 'variable for start position of search
For n = 1 To -Delim2Inst
TxtFnsh = InStrRev(LocalText, Delim2, TxtFnsh)
TxtFnsh = TxtFnsh - 1
Next
TxtFnsh = TxtFnsh + 1
End If
'**************************************************************
'Now get the part of the text required
XtndMid = Mid(LocalText, TxtStrt, TxtFnsh - TxtStrt)
Exit Function
'
ErrEnd:
End Function
Back to Top of Page
Lookup Functions
- Extended Vertical lookup function
- Find Instance function
- Consolidate data function
- Download the code for the Lookup Functions
1. Extended vertical lookup function
An extended vertical lookup function is included.
Excel's vertical lookup function –VLookup –is limited to returning data from cells to the right of the search data
and on the same row that the search value is found.
The extended vlookup allows values to be returned from cells to the right or left of the search cells, and the search can be offset
up or down by any number of rows.
If the horizontal offset is set to zero, a vertical offset allows the value before or after the search value to be returned.
Also, extended vlookup can find the nth instance of the search data. If the instance value is negative, the value is searched for,
starting at the end of the range. A search instance of -1 will return the last instance of the search item in the specified range.
The formula used in a cell is: =XtndVLookup(SearchRange, SearchValue, HOffset, VOffset, Instance, Match)
SearchRange is a single column of cells containing the values to be searched.
SearchValue is the value to be found in the cells in the SearchRange,
HOffset is the number of columns to the right or left of the SearchRange column, to return a value. If VOffset is empty or = zero, then
the result is returned from the same row as the cell containing the matching data. If omitted, HOffset defaults to +1. Negative values
return results from columns to the left of the SearchRange column. If HOffset = 0 then the results are returned from the SearchRange column
itself, –of use when combined with VOffset to find a value before or after the search item.
VOffset is a vertical offset in the returned data column. Voffset defaults to 0, but can be a positive or negative number.
Setting HOffset = 0 and Voffset = 0 is a special case. Rather than return the SearchValue, XtndVlookup returns the position or offset
of the instance of the item in the SearchRange column. The first cell in the Search range has a zero offset, the second cell has
an offset of 1 etc. (Offsets are always from the start of the range, even when the search instance is negative).
Instance is the instance of the SearchValue to be found. If a negative value is used, the search starts at the end of the search range.
Match is True or False and defaults to True, i.e., the search text is matched for case. In the formula enter TRUE or 1 to match case,
or FALSE or 0 for no case matching.
The following picture shows a grid of results (D7 to F9). The search data is in blue (cells I3 to I10), with result data in columns H and J
on either side. Results in cells D7, D8 & D9 have used a horizontal offset of -1 and return results from column H. Similarly results in cells F7,
F8 & F9 use an Hoffset of +1 and return results from column J. Results in cells E7, and E9 have a zero offset and return results from the search
range column, depending on the vertical offset used. The result in cell E8 is the special case where both Hoffset and Voffset are zero
and the result is an offset value from the start of the search range.
The next image shows the formulas in cells E7, E8 and E9. The formulas in the other yellow colored cells follow the same pattern.
In this example, the Match parameter has been omitted and will default to True.
Add the following code to a module –See How to add a routine to your copy of Excel
(Note that this is a user defined function, not a macro).
Public Function XtndVlookup(SearchRange As Object, SearchValue As String, HIndex As Integer, Optional VIndex As Double = 0, Optional SearchInst As Integer = 2, Optional MatchYorN As Boolean = True)
'*****************************************************************************************
'User Defined Function that extends Vlookup
'© Humar Consulting 2007
'Version 1.03 May 2007 revised July 2007
'*****************************************************************************************
Dim dblSrchRowStart As Double 'First row in search range
Dim dblSrchRowEnd As Double 'Last row in search range
Dim intSrchCol As Integer 'Search column
Dim dblSrchRows As Double 'number of search rows in range
Dim InstanceCount As Integer 'Loop counter for instances of search item
Dim XtndResult As Variant 'Holder for result - offset from 'Find' location
Dim XtndFind As Object 'Object to hold information about search location
Dim WkSht As Object 'Name of Worksheet with search range
Dim WkBkNme As String 'Name of Workbook with search range'
'counters
Dim dbla As Double
Dim dblr As Double
'*****************************************************************************************
On Error GoTo ErrHand
'*****************************************************************************************
'Get worksheet and workbook names
Set WkSht = SearchRange.Worksheet
If WkSht Is Nothing Then WkSht = ActiveCell.Worksheet.Name
WkBkNme = WkSht.Parent.Name
'*****************************************************************************************
'Get Range origins & size and create search range
'set search range as starting one row before actual start
dblSrchRowStart = SearchRange.Row - 1
intSrchCol = SearchRange.Column
dblSrchRows = SearchRange.Rows.Count
dblSrchRowEnd = dblSrchRowStart + dblSrchRows
'Test Search range to ensure that it is a single Column
If SearchRange.Columns.Count <> 1 Then
XtndVlookup = CVErr(xlErrRef)
GoTo ErrEnd
End If
'*****************************************************************************************
'Test that results columns and rows are valid
'Test VIndex –ensure that it is within range(rows 1 to 65536)
dbla = SearchRange.Row + VIndex
If dbla < 1 Or (dbla + dblSrchRows - 1) > 65536 Then
XtndVlookup = CVErr(xlErrRef)
GoTo ErrEnd
End If
'Test HIndex –ensure that it is within range (columns A to IV)
dbla = SearchRange.Column + HIndex
If dbla < 1 Or dbla > 256 Then
XtndVlookup = CVErr(xlErrRef)
GoTo ErrEnd
End If
'*****************************************************************************************
'Set search range to include worksheet name and workbook name, so that function will work
'on other worksheets, and in other workbooks, not just the active worksheet.
Set SearchRange = Workbooks(WkBkNme).Worksheets(WkSht.Name).Range(Workbooks(WkBkNme). _
Worksheets(WkSht.Name).Cells(dblSrchRowStart, intSrchCol), Workbooks(WkBkNme).Worksheets(WkSht.Name).Cells(dblSrchRowEnd, intSrchCol))
'*****************************************************************************************
'Test search for more instances than exist
If WorksheetFunction.CountIf(SearchRange, SearchValue) < SearchInst Then
XtndVlookup = CVErr(xlErrValue)
GoTo ErrEnd
End If
'*****************************************************************************************
'Go to normal or reverse search depending on whether search instance is Positve or Negative
'Search Instance = 0 is a special case, but is searched using the normal search order
If SearchInst > - 1 Then
'*****************************************************************************************
'Normal (forward) search
With SearchRange
'set initial row for 'After' value of the Find function
dblr = 1
For InstanceCount = 1 To SearchInst
'This Find, uses offset to get the lookup value
Set XtndResult = .Find(What:=SearchValue, after:=.Cells(dblr, 1), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=MatchYorN).Offset(VIndex, HIndex)
'This Find is to check that the instance of the search item is present
Set XtndFind = .Find(What:=SearchValue, after:=.Cells(dblr, 1), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=MatchYorN)
'Calculate new offset (After value) to start next iteration of the Find function
dblr = XtndFind.Row - dblSrchRowStart + 1
Next
End With
'*****************************************************************************************
'Reverse Search
Else
With SearchRange
'set initial row for 'After' value of the Find function
dblr = 1
'Make the search instance count positive
SearchInst = –SearchInst
For InstanceCount = 1 To SearchInst
'This Find, uses offset to get the lookup value
Set XtndResult = .Find(What:=SearchValue, after:=.Cells(dblr, 1), _
LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlPrevious, _
MatchCase:=MatchYorN).Offset(VIndex, HIndex)
'This Find is to check that the instance of the search item is present
Set XtndFind = .Find(What:=SearchValue, after:=.Cells(dblr, 1), _
LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlPrevious, _
MatchCase:=MatchYorN)
'Calculate new offset (After value) to start next iteration of the Find function
dblr = XtndFind.Row - dblSrchRowStart + 1
Next
End With
End If
'*****************************************************************************************
'Test if search item not found
'If requested search was for an empty cell then ignore this test
If SearchValue <> "" Then
If XtndFind = Empty Then
XtndFind = CVErr(xlErrValue)
GoTo ErrEnd
End If
End If
'*****************************************************************************************
'valid result –return it in the function
'If HIndex & Vindex are zero, this is a special case, returning the relative vertical
'offset of the search item in the index column, (the first row is a zero offset)
If HIndex = 0 And VIndex = 0 Then
XtndVlookup = XtndFind.Row - dblSrchRowStart - 1
Else
XtndVlookup = XtndResult.Value
End If
Exit Function
'*****************************************************************************************
'Non–program errors jump here (error value is already set)
ErrEnd:
Exit Function
'*****************************************************************************************
'if Program error return #NA
ErrHand:
XtndVlookup = CVErr(xlErrNA)
End Function
'*****************************************************************************************
2. Find Instance function
The find instance function returns the address of the cell containing the search value, from the search range. As the name implies
the function can be used to find the nth instance of the search value. If the search instance is negative, then the search starts at the
end of the search range. A search instance of -1 will return the last occurrence of the search value in the search range.
The formula is: =FindInst(SearchRange, SearchValue, Instance, Match).
SearchRange is the range of cells to be searched.
SearchValue is the value to be found in the cells in the SearchRange
Instance is the instance of the SearchValue to be found. If a negative value is used, the search starts at the end of the search range.
Match is True or False and defaults to True, i.e., the search text is matched for case. In the formula enter TRUE or 1 to match case,
or FALSE or 0 for no case matching.
In the example used for the extended Vlookup, FindInst would return I7, i.e., the cell containing the second instance of 'd'. If the instance was
-1 then the result would be I10.
Add the following code to a module –See How to add a routine to your copy of Excel
(Note that this is a user defined function, not a macro).
Public Function FindInst(SearchRange As Range, SearchValue As String, Optional SearchInstance As Integer = 2, Optional MatchYorN = True) As Variant
'© Humar Consulting 2007
'Version 1.02 June 2007
'Finds the Nth instance of the search string in the range specified, and
'returns the address of the search string.
'Note that this search doesn't use FindNext –as FindNext doesn't work when called from a cell function!
'********************************************************************
Dim InstFind As Object 'the single cell range of the instance found by the .Find function
Dim strFrstFnd As String 'string to hold the address of the first instance found –used to stop Find from looping round the search range
Dim rngNxtAddr As Range 'used to reset the .Find, so that it searches the range after the last matching cell
Dim rngLastAddr As Range 'used to hold the last address found, not the current one –needed when there are more instances found than required
Dim intFindCnt As Integer 'counts number of matching cells
Dim dblFndNxtRw As Double 'used when converting last address to a row value
Dim intFndNxtCl As Integer 'used when converting last address to a column value
'********************************************************************
On Error GoTo ErrHnd
If SearchInstance = 0 Then GoTo ErrHnd
'********************************************************************
'Search for instance –forward or backward depending on value of search instance
If SearchInstance > 0 Then
'forward search through range
With SearchRange
intFindCnt = 0
'first search –start After last cell in range, i.e., starts at first cell
'this is a quirk of the find method which starts after the active cell or after the first cell in the range
Set InstFind = .Find(What:=SearchValue, after:=.Cells(SearchRange.Rows.Count, SearchRange.Columns.Count), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=MatchYorN)
If Not InstFind Is Nothing Then
'if an instance found then test if searchinstance =1. If >1 go on to test some more
If SearchInstance = 1 Then
intFindCnt = 1
Set rngLastAddr = InstFind
Else
intFindCnt = 1
strFrstFnd = InstFind.Address
Set rngNxtAddr = InstFind
Do
'to re-use Find we need to specify that it starts after the last found location
dblFndNxtRw = rngNxtAddr.Row - SearchRange.Row + 1
intFndNxtCl = rngNxtAddr.Column - SearchRange.Column + 1
Set rngLastAddr = rngNxtAddr
Set InstFind = .Find(What:=SearchValue, after:=.Cells(dblFndNxtRw, intFndNxtCl), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=MatchYorN)
If Not InstFind Is Nothing Then
intFindCnt = intFindCnt + 1
Set rngNxtAddr = InstFind
End If
Loop While Not InstFind Is Nothing And InstFind.Address <> strFrstFnd And intFindCnt < SearchInstance
'get out of loop if no more instances of search value found, or we have looped back to the start
'or we have found the required number of instances
'if loop stopped for required instance found keep the latest address
If intFindCnt = SearchInstance Then Set rngLastAddr = rngNxtAddr
End If
End If
End With
Else
'reverse search through range
'make SearchInstance positive for our counts
SearchInstance = - SearchInstance
With SearchRange
intFindCnt = 0
'first search - start After first cell in range, i.e., starts at last cell
'this is a quirk of the find method which starts after the active cell or after the first cell in the range
'note use SearchDirection = xlPrevious
Set InstFind = .Find(What:=SearchValue, after:=.Cells(SearchRange.Rows.Count, SearchRange.Columns.Count), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=MatchYorN)
If Not InstFind Is Nothing Then
'if an instance found then test if searchinstance =1. If >1 go on to test some more
If SearchInstance = 1 Then
intFindCnt = 1
Set rngLastAddr = InstFind
Else
intFindCnt = 1
strFrstFnd = InstFind.Address
Set rngNxtAddr = InstFind
Do
'to re-use Find we need to specify that it starts after the last found location
dblFndNxtRw = rngNxtAddr.Row - SearchRange.Row + 1
intFndNxtCl = rngNxtAddr.Column - SearchRange.Column + 1
Set rngLastAddr = rngNxtAddr
Set InstFind = .Find(What:=SearchValue, after:=.Cells(dblFndNxtRw, intFndNxtCl), LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=MatchYorN)
If Not InstFind Is Nothing Then
intFindCnt = intFindCnt + 1
Set rngNxtAddr = InstFind
End If
Loop While Not InstFind Is Nothing And InstFind.Address <> strFrstFnd And intFindCnt < SearchInstance
'get out of loop if no more instances of searchvalue found, or we have looped back to the start
'or we have found the required number of instances
'if loop stopped for instance found keep the latest address
If intFindCnt = SearchInstance Then Set rngLastAddr = rngNxtAddr
End If
End If
End With
End If
'********************************************************************
'If search value not found in range, or the requested instance is not found –return an error
'else return the address (with worksheet name, if on different sheet to the formula)
If intFindCnt = 0 Or intFindCnt < SearchInstance Or InstFind.Address = strFrstFnd Then
FindInst = CVErr(xlErrValue)
Else
'set the return value to the last address found
If ActiveSheet.Name = rngLastAddr.Worksheet.Name Then
FindInst = rngLastAddr.Address
Else
FindInst = rngLastAddr.Worksheet.Name & "!" & rngLastAddr.Address
End If
End If
Exit Function
'********************************************************************
ErrHnd:
FindInst = CVErr(xlErrNA)
End Function
3. Data Consolidation function
'This function allows data to be consolidated, e.g., by groups of three months to make a quarter, 4 quarters to make a year etc.
The standard Excel function to extend a formula doesn't work correctly for this use.
For example a formula =A1+B1+C1, if extended (dragged), one cell to the right, becomes =B1+C1+D1, but what is
required is D1+E1+F1, and in the next cell G1+H1+I1.
This function performs the data consolidation, without creating formulas in the A1+B1+C1 format.
This function can consolidate (add groups of cells) in either the horizontal direction or the vertical direction.
With the optional 'transpose' value, horizontally arranged data can be displayed vertically, and the other way round.
The four arguments to this function are:
1. The range of cells containing the raw data, e.g., monthly data;
2. The starting cell for the 'consolidation, i.e., the start of the result table;
3. The number of cells to be consolidated, e.g., 12 for consolidating months into years;
4. A true or false value 'transpose' which allows the results to be horizontal when the
data is vertical, or vice-versa. Transpose is optional and defaults to false.
Example =Consldt($C$5:$V$5, $AA$5, 4) –the transpose value (true or false or the values 1 or 0) is optional and defaults
to 'False' which is what is required in this formula as the results table is in the same orientation as the raw data.
If C5 to V5 contain 20 quarterly data values, then a table starting at AA5
will have annual data. The formula is dragged from AA5 to AE5,
i.e., for 5 years of consolidated data. AA5 will be the sum of C5+D5+E5, AB5 will be the sum of F5+G5+H5 etc.
Use $ before columns in the argument list to keep the same starting point for both the original data and
the table of consolidated results, i.e., use absolute column addressing, ($C5:$V5), or absolute addressing, ($C$5:$V$5).
If the data is arranged vertically then use absolute row addressing (C$5:C$24), or absolute addressing, ($C$5:$C$24).
The start of the results table must be the same in every result table cell, so again use absolute addressing for this
address.
The following image shows 24 months of data in cells C3 to C26 and quarterly results in cells E4 to L4.
The consolidate formula is the same in all cells in the results table '=consldt($C$3:$C$26,$E$4,3,TRUE). The data range has
been entered as an absolute address range ($C$3:$C$26), and the start of the results table has also been entered as an absolute
address ($E$4), so that these addresses do not change when the formula is dragged, to fill cells F4 to L4.
The value 3 indicates that the values in three cells are added each time, and 'TRUE' indicates that the result table is
transposed in direction from the source data table.
Add the following code to a module –See How to add a routine to your copy of Excel
(Note that this is a user defined function, not a macro).
Public Function Consldt(DataRange As Range, RsltTblOrigin As Range, AddWidth As Integer, Optional Transpose As Boolean = False) As Variant
'
'*******************************************************************
'© Humar Consulting Inc. 2005, 2007
'August 2005, modified July 2007
'Function to add (consolidate) data into groups, e.g. months into quarters
'*******************************************************************
Dim NewFmlaCol As Integer 'Column of the formula
Dim NewFmlaRow As Double 'Row of the formula
Dim DataRangeCol As Integer 'Start column of the data range
Dim DataRangeRow As Double 'Start row of the data range
Dim RsltTblOriginCol As Integer 'Column of the base of the results table
Dim RsltTblOriginRow As Double 'Row of the base of the results table
Dim blnIsHz As Boolean 'Flag for horizontal or vertical, (true=horiz)
Dim NewTotal As Double 'Variable to hold new total
Dim n As Integer 'Loop counter
'*******************************************************************
'Get column & row for result location, (address of calling cell)
NewFmlaCol = Application.Caller.Column
NewFmlaRow = Application.Caller.Row
'*******************************************************************
'Get column & row info. for start of data and start of results table
DataRangeCol = DataRange.Column
DataRangeRow = DataRange.Row
RsltTblOriginCol = RsltTblOrigin.Column
RsltTblOriginRow = RsltTblOrigin.Row
'*******************************************************************
'Decide if data is horizontal or vertical
'check that data is single column or single row
If DataRange.Columns.Count > 1 And DataRange.Rows.Count > 1 Then
Consldt = CVErr(xlErrRef)
GoTo ErrEnd:
End If
If DataRange.Columns.Count > 1 Then
blnIsHz = True
Else
blnIsHz = False
End If
'*******************************************************************
'select if horizontal or vertical data
If blnIsHz = True Then
'*******************************************************************
'Horizontal data
'Calculate the starting offset - Use start of data column plus
'((number of columns from Result Table base to 'this' column) * width)
'if Transpose set, calculate offset using row difference
If Transpose = False Then
DataRangeCol = DataRangeCol + ((NewFmlaCol - RsltTblOriginCol) * AddWidth)
Else
DataRangeCol = DataRangeCol + ((NewFmlaRow - RsltTblOriginRow) * AddWidth)
End If
'*******************************************************************
'test that all cells to be summed, are in the data range
'return the REF error if results would exceed specified data range
If DataRangeCol + AddWidth - 1 > DataRange.Column + DataRange.Columns.Count Then
Consldt = CVErr(xlErrRef)
GoTo ErrEnd
End If
'*******************************************************************
'Add up the required cells using offset from Database origin & width
NewTotal = 0
For n = 1 To AddWidth
NewTotal = NewTotal + Cells(DataRangeRow, DataRangeCol + n - 1).Value
Next
Else
'*******************************************************************
'Vertical data
'Calculate the starting offset - Use start of data row plus
'((number of rows from Result Table base to 'this' row) * width)
'if Transpose set, calculate offset using column difference
If Transpose = False Then
DataRangeRow = DataRangeRow + ((NewFmlaRow - RsltTblOriginRow) * AddWidth)
Else
DataRangeRow = DataRangeRow + ((NewFmlaCol - RsltTblOriginCol) * AddWidth)
End If
'*******************************************************************
'test that all cells to be summed, are in the data range
'return the REF error if results would exceed specified data range
If DataRangeRow + AddWidth - 1 > DataRange.Row + DataRange.Rows.Count Then
Consldt = CVErr(xlErrRef)
GoTo ErrEnd
End If
'*******************************************************************
'Add up the required cells using offset from Database origin & width
NewTotal = 0
For n = 1 To AddWidth
NewTotal = NewTotal + Cells(DataRangeRow + n - 1, DataRangeCol).Value
Next
End If
'*******************************************************************
'Put the result into the function name, to display the result in the cell
Consldt = NewTotal
Exit Function
'*******************************************************************
'errors jump here
ErrHnd:
Consldt = CVErr(xlErrNA)
ErrEnd:
End Function
Back to Top of Page
Tables & Charts
One macro formats a table, with headings, lines and a totals line. This macro is suitable for customization, so that you can quickly
format a table on your spreadsheet in a style that suits you.
The second macro will re–size a chart to the same size as an existing chart, and align the left margins. When you add charts to
a worksheet, there is no easy way to make the charts the same size, unless you start by copying an existing chart. If you put charts
side–by–side, rather than stacked vertically, the macro could be changed to make the tops of the charts align, rather than
the left edges, as in this macro.
1. Table Format
The following images show a table before and after running the format macro.
Add the following code to a module –See How to add a routine to your copy of Excel
Sub Combo_Totals_Border()
'********************************************************************
'© Humar Consulting February 2006
'Routine to create a box border with grey horizontals, black verticals
'and the with one header row for titles and one footer row
'for totals. Puts a heavy border below the titles and a double border
'above the totals. Centres the top and bottom rows - vertically and
'horizontally. Bold the text in the top row.
'********************************************************************
Dim intRowsCount As Integer
Dim intTopRow As Integer
Dim intColsCount As Integer
Dim intLeftCol As Integer
'********************************************************************
On Error Resume Next
'********************************************************************
'Apply the outer box and all inside line borders
'inside horizontals are grey, all others black
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = 3
.ColorIndex = 1
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = 3
.ColorIndex = 1
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = 3
.ColorIndex = 1
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = 3
.ColorIndex = 1
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 15
End With
'********************************************************************
'now find the selection one row down from top and above the final row
With Selection
intRowsCount = .Rows.Count
intTopRow = .Row
intColsCount = .Columns.Count
intLeftCol = .Column
End With
'********************************************************************
'Setup the new range and make the top border - single line, black and bottom border –double line, black
With Range(Cells(intTopRow + 1, intLeftCol), Cells(intTopRow + intRowsCount - 2, intLeftCol + intColsCount - 1))
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlDouble
.Weight = xlThick
.ColorIndex = 1
End With
End With
'********************************************************************
'Centre the cells in the top row - Horizontal and Vertical and make Bold
With Range(Cells(intTopRow, intLeftCol), Cells(intTopRow, intLeftCol + intColsCount - 1))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlVAlignCenter
.Orientation = 0
.Font.FontStyle = "Bold"
End With
'********************************************************************
'Centre the cells in the bottom row –Horizontal and Vertical
With Range(Cells(intTopRow + intRowsCount - 1, intLeftCol), Cells(intTopRow + intRowsCount - 1, intLeftCol + intColsCount - 1))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlVAlignCenter
.Orientation = 0
End With
'********************************************************************
End Sub
2. Size & Align Charts
This routine makes the last chart created, the same size as a chart that you have selected, (must be on the same worksheet) then it horizontally aligns the new chart with the selected chart.
Add the following code to a module –See How to add a routine to your copy of Excel
Sub PositionChart()
'***************************************************************
'Chart size & align routine
'© Humar Consulting 2006, 2007
'Version 1.03 July 2007
'Gets the size of the selected chart and applies it to the last chart created and lines up
'the left edge of the last chart created with the left edge of the selected chart,
'or aligns the tops of the two charts, depending on their initial, relative positions.
'***************************************************************
Dim nlast As Integer
Dim chtLast As ChartObject
Dim chtWidth As Integer
Dim chtHeight As Integer
Dim chtLeft As Integer
Dim chtCellTopLeft As Variant
'***************************************************************
'get dimensions & position of the selected chart (not the last chart created)
With ActiveChart.Parent
chtWidth = .Width
chtHeight = .Height
chtLeft = .Left
chtTop = .Top
End With
'***************************************************************
'get active workbook and worksheet names
WkbActive = ActiveWorkbook.Name
WksActive = ActiveSheet.Name
'***************************************************************
'identify the last chart created
nlast = ActiveSheet.ChartObjects.Count
'***************************************************************
'resize & reposition the last chart
With Worksheets(WksActive).ChartObjects(nlast)
.Width = chtWidth
.Height = chtHeight
.Left = chtLeft
'align top of last chart with top of nearest row - just to be tidy!
chtCellTopLeft = .TopLeftCell.Address
.Top = Range(chtCellTopLeft).Top
End With
End Sub
Back to Top of Page
Display Macros
The first routine is a simple flip to hide or show the default gridlines on the active spreadsheet.
There are then two merge cell macros. These allow cells in a selected area to be merged by rows or by columns.
Excel's merge functions, merge all cells in a selected area into one merged cell. These routines allow groups of cells to be merged,
either group of cells in rows or groups of cells in columns.
- Show or Hide Gridlines
- Merge cells by Row function
- Merge cells by Column function
- Download the code for the display macros
1. Show or Hide Gridlines
When you are formatting charts and tables on your spreadsheet, you may not want the default gridlines showing. These can be turned off by going to Tools –Options –View and then uncheck the Gridlines box. This is replaced by a single click on a custom button to run this macro. This routine flips gridlines on to off or off to on. This is a very short piece of code but if you want to format a spreadsheet to look good, with formatted tables or charts then you don't want the default gridlines on, this routine allows you to rapidly flip the gridlines on or off.
Add the following code to a module –See How to add a routine to your copy of Excel
Public Sub ToggleGridlines()
'
'© Humar Consulting February 2006
'Version 1.00
'Toggles Gridlines between visible and hidden
'******************************************************
On Error GoTo ErrHnd
'******************************************************
'Only toggle if the active selection is a spreadsheet - ignore if chart etc.
If TypeName(Selection) = "Range" Then
'******************************************************
'Flip flop the gridline display
With ActiveWindow
If .DisplayGridlines = True Then
.DisplayGridlines = False
Else
.DisplayGridlines = True
End If
End With
End If
Exit Sub
'******************************************************
ErrHnd:
Err.Clear
End Sub
'******************************************************
2. Merge cells by Row function
The following two images show the effect of merge by row. The outlines of the merged cells have been added separately, for
clarity. The MergeByRow macro does not change cell border properties.
This routine also keeps the values in all the merged cells. Excel's merge function only keeps the value in the top left cell, which is very annoying, when you happen to have text in several cells that are being merged. If the merged cells contain only numbers, (or numbers and empty cells), then the numbers are added together and displayed in the merged cell. If all, or any of the cells contain text, the text is joined (concatenated), and displayed in the merged cells. A space is added between the words. If there is text as well as numbers in the cells, then the numbers are treated as text.
Add the following code to a module –See How to add a routine to your copy of Excel
Sub MergeByRow()
'Merge Cells by Row routine
'© Humar Consulting
'Version 1.02 October 2007
'A subroutine to merge cells in selected area, by row
'*****************************************************************************************
Dim rwnum As Double 'number of rows
Dim clnum As Integer 'number of columns
Dim clstart As Integer 'first column
Dim clfinish As Integer 'last column
Dim rw As Double 'row for each merge
Dim MergeRangeName As String 'address for each merge range
Dim ClsToMrg As Range 'range for cells to be merged
Dim blnMnumeric As Boolean 'flag for all numeric values in a range to be merged
Dim blnAllzero As Boolean 'flag for all numbers zero or no real numbers
Dim strMtext As String 'string to hold merged text
Dim dblMnum As Double 'variable to hold added numbers
Dim n As Integer 'loop counter
Dim nn As Integer 'loop counter
'*****************************************************************************************
On Error GoTo ErrHnd
'*****************************************************************************************
With Selection
rwnum = Selection.Rows.Count
clnum = Selection.Columns.Count
For n = 1 To rwnum
rw = Selection.Row + n - 1
clstart = Selection.Column
clfinish = clstart + clnum - 1
'test if there are only numbers
blnMnumeric = True
For nn = clstart To clfinish
If Not IsNumeric(ActiveSheet.Cells(rw, nn).Value) Then
blnMnumeric = False
End If
Next
'get text or numbers and clear individual cells as we go through
If blnMnumeric = True Then
'all numbers so add
dblMnum = 0
blnAllzero = True
For nn = clstart To clfinish
dblMnum = dblMnum + ActiveSheet.Cells(rw, nn).Value
'just check that we dont have all zeros or no real numbers at all
If ActiveSheet.Cells(rw, nn).Value <> 0 Then blnAllzero = False
ActiveSheet.Cells(rw, nn).Value = ""
Next
Else
'text or mixed values, so concatenate
strMtext = ""
For nn = clstart To clfinish
'only concatenate if there is something to concatenate!
If ActiveSheet.Cells(rw, nn).Text <> "" And ActiveSheet.Cells(rw, nn).Text <> " " Then
strMtext = strMtext & " " & ActiveSheet.Cells(rw, nn).Text
End If
ActiveSheet.Cells(rw, nn).Value = ""
Next
'remove extraneous spaces
strMtext = Trim(strMtext)
End If
'create merge range name
MergeRangeName = "R" & Format(rw, "#0") & "C" & Format(clstart, "#0") & ":" & "R" & Format(rw, "#0") & "C" & Format(clfinish, "#0")
MergeRangeName = Application.ConvertFormula(Formula:=MergeRangeName, fromReferenceStyle:=xlR1C1, toReferenceStyle:=xlA1)
'merge the cells in the range
Set ClsToMrg = Range(MergeRangeName)
With ClsToMrg
.MergeCells = True
End With
'put merged text or added number in first cell in range
If blnMnumeric = True Then
'enter new number unless it's 0
If blnAllzero = False Then
ActiveSheet.Cells(rw, clstart).Value = dblMnum
End If
Else
'enter new text
ActiveSheet.Cells(rw, clstart).Value = strMtext
End If
Next
End With
Exit Sub
'*****************************************************************************************
'errors jump here
ErrHnd:
Err.Clear
End Sub
'******************************************************
3. Merge Cells by Column function
The following two images show the effect of merge by column. The outlines of the merged cells have been added separately, for
clarity. The MergeByColumn macro does not change cell border properties.
This routine also keeps the values in all the merged cells. Excel's merge function only keeps the value in the top left cell,
which is very annoying, when you happen to have text in several cells that are being merged. If the merged cells contain only
numbers, (or numbers and empty cells), then the numbers are added together and displayed in the merged cell. If all, or any of
the cells contain text, the text is joined (concatenated), and displayed in the merged cells. A space is added between the words.
If there is text and numbers in the cells, then the numbers are treated as text. Merge by Column also centres the text both horizontally
and vertically and allows text wrapping. The following two images show rows 2 & 3 with text in one or other or both rows, converted
to a single merged row. Cells B2 to F3 were selected before running the Merge Cells by Column routine.
Add the following code to a module –See How to add a routine to your copy of Excel
Sub MergeByColumn()
'Merge Cells by Column routine
'© Humar Consulting
'Version 1.02 October 2007
'A subroutine to merge cells in selected area, by column
'**************************************************
Dim rwnum As Double 'number of rows
Dim clnum As Integer 'number of columns
Dim rwstart As Double 'first row
Dim rwfinish As Double 'last row
Dim cl As Integer 'column for each merge
Dim MergeRangeName As String 'address for each merge range
Dim RwsToMrg As Range 'range for cells to be merged
Dim blnMnumeric As Boolean 'flag for all numeric values in a range to be merged
Dim blnAllzero As Boolean 'flag for all numbers zero or no real numbers
Dim strMtext As String 'string to hold merged text
Dim dblMnum As Double 'variable to hold added numbers
Dim n As Integer 'loop counter
Dim nn As Integer 'loop counter
'*****************************************************************************************
On Error GoTo ErrHnd
'*****************************************************************************************
With Selection
rwnum = Selection.Rows.Count
clnum = Selection.Columns.Count
For n = 1 To clnum
cl = Selection.Column + n - 1
rwstart = Selection.Row
rwfinish = rwstart + rwnum - 1
'test if there are only numbers
blnMnumeric = True
For nn = rwstart To rwfinish
If Not IsNumeric(ActiveSheet.Cells(nn, cl).Value) Then
blnMnumeric = False
End If
Next
'get text or numbers and clear individual cells as we go through
If blnMnumeric = True Then
'all numbers so add
dblMnum = 0
blnAllzero = True
For nn = rwstart To rwfinish
dblMnum = dblMnum + ActiveSheet.Cells(nn, cl).Value
'just check that we dont have all zeros or no real numbers at all
If ActiveSheet.Cells(nn, cl).Value <> 0 Then blnAllzero = False
ActiveSheet.Cells(nn, cl).Value = ""
Next
Else
'text or mixed values, so concatenate
strMtext = ""
For nn = rwstart To rwfinish
'only concatenate if there is something to concatenate!
If ActiveSheet.Cells(nn, cl).Text <> "" And ActiveSheet.Cells(nn, cl).Text <> " " Then
strMtext = strMtext & " " & ActiveSheet.Cells(nn, cl).Text
End If
ActiveSheet.Cells(nn, cl).Value = ""
Next
'remove extraneous spaces
strMtext = Trim(strMtext)
End If
'create merge range name
MergeRangeName = "R" & Format(rwstart, "#0") & "C" & Format(cl, "#0") & ":" & "R" & Format(rwfinish, "#0") & "C" & Format(cl, "#0")
MergeRangeName = Application.ConvertFormula(Formula:=MergeRangeName, fromReferenceStyle:=xlR1C1, toReferenceStyle:=xlA1)
Set RwsToMrg = Range(MergeRangeName)
With RwsToMrg
.MergeCells = True
.WrapText = True
.HorizontalAlignment = xlHAlignCenter
.VerticalAlignment = xlVAlignCenter
End With
'put merged text or added number in first cell in range
If blnMnumeric = True Then
'enter new number unless it's 0
If blnAllzero = False Then
ActiveSheet.Cells(rwstart, cl).Value = dblMnum
End If
Else
'enter new text
ActiveSheet.Cells(rwstart, cl).Value = strMtext
End If
Next
End With
Exit Sub
'*****************************************************************************************
'errors jump here
ErrHnd:
Err.Clear
End Sub
'******************************************************
Back to Top of Page
Date & Time
There are three date or time functions.
The first function creates text from a start and an end time. The text can be easily manipulated, avoiding the need to format cells
with specialized format codes. This function is useful for timesheets, reports and invoices.
The second function enters today's date into a cell, formatting the date in your 'short date' format, but it is easily adaptable to format the date
in other styles. This is a quick way to ensure that the date is always entered in a consistent style.
- Time message text
- Enter Today's Date
- Day of the Week function
- Download the code for all the date/time functions
1. Time Message Text function
TimeMsg is a function that calculates the difference in time between two Excel Date/Time values and adds additional text,
suitable for use in reports, timesheets, invoices etc.
The formula used is: '=TimeMsg(StTm, NdTm, DispType, YourDays, YourHours, YourMinutes)'.
The 3 'Your' values are optional, and are only used with certain Display types (DispType). DispType is a number which
identifies the text to display and also controls the way that the start and end times are used.
Excel's time formats do not adapt to different durations, for example a format of "[h]"Hours and "m" Minutes"displays
0.06 as 1 Hours and 26 Minutes, and 0.001 as 0 Hours and 01 Minutes. This function adapts the text to singular or plural
as appropriate and supresses the hours or minutes text if either is zero. Options allow days in the Date/Time difference
to be converted to hours, to be displayed, or to be ignored. Suppressing the date portion of the difference is usefull
because when times are entered, the date portion may not be visible and may not be correct, defaulting to 01 January 1900
when only a time is entered in a cell.
The values StTm (start time) and NdTm (end time), are Excel date/time values, (a positive number between zero and 2958465
... in Excel 2003). The time component is the decimal or fractional part of the number. If NdTm is less than StTm, and the
DispType is less than 10, (i.e., ignore date component), the function assumes that the end time is after midnight, and
calculates accordingly. DispType allows the user to select the text part of the display, e.g., Hours or Hrs etc. If
Display Option 9 is selected the user-defined 'YourHours' and 'YourMinutes' text is used instead of the built-in text
options.
Disp Types in the 1 to 9 range ignore the date component, so erroneous date values are ignored.
DispType in the 10 to 19 range convert any day differences into hours.
DispType in the 20 to 29 range display day differences together with the time difference.
The three 'Your' values are user defined display text for days, hours and minutes used by the 9, 19 and 29 display types.
The eight built-in texts are selected using DispType in the ranges 1 to 8, 11 to 18, and 21 to 28
If Display Options 9, 19 or 29 are selected the YourHours and YourMinutes text is used instead of the built-in text and for
display option 29, the YourDays text is used as well.
To include customized joining text between days and hours and hours and minutes, separate your user defined text with a'^' character.
For example, a time difference displayed using display type 29, which is a user defined text with display of days differences, as well as
hours and minutes, the following formula/parameters '=TimeMsg(A2,B2,29," interminable days^ plus "," boring hours^
& ", " mindless minutes")' produces the following:
'1 interminable day plus 2 boring hours & 10 mindless minutes',
(Cell A2 contains the start time/date and B2 the end time/date).
Using DispType 19 in the formula returns:
'26 boring hours & 10 mindless minutes', but display option 14 returns: '26 hours and 10 minutes', because this
uses built–in text, and ignores the user entered text and joining words.
If the DispType is omitted, the function defaults to display type 1.
The following image shows some examples of the function.
Note that Excel help states that time differences can be displayed using the Text function, but this is very limited, and cannot display
additional text, such as 'and' or 'mindless'!. Text also cannot automatically adjust for singular or plural.
If you have a preferred date display format, you could modify the program so that one of the options contains your text. This removes the
need to enter the user 'YourDay/Hour/Minute' text, to get the format you want. The main text options are in the section starting with
Select Case. Nearer the top of the program are the default 'joins' ',' and 'and'. These can be changed.
Add the following code to a module –See How to add a routine to your copy of Excel
Public Function TimeMsg(StTm As Date, Optional NdTm As Date = 0, Optional DispType As Integer = 1, Optional YourDays, Optional YourHours, Optional YourMinutes)
'
'*****************************************************************************************
'Time display message
'© Humar Consulting 2005, 2007
'Version 1.02 February 2005, Revised July 2007
'
'*****************************************************************************************
Dim lngDay As Long
Dim sngTime As Single
Dim lngDy As Long
Dim lngHr As Long
Dim intMn As Integer
Dim blnNeg As Boolean
Dim strBaseDyTxt As String
Dim strBaseHrTxt As String
Dim strBaseMnTxt As String
Dim strDyTxt As String
Dim strHrTxt As String
Dim strMnTxt As String
Dim strCon1 As String
Dim strCon2 As String
'*****************************************************************************************
On Error GoTo ErrHnd
'*****************************************************************************************
'Test for non valid Display types
If DispType < 1 Or DispType = 10 Or DispType = 20 Or DispType > 29 Then
TimeMsg = CVErr(xlErrValue)
GoTo ErrEnd
End If
'*****************************************************************************************
'set connecting text for joining parts, e.g., 10 hours AND 2 minutes
'user defined text includes these if '^' present
'default text for all messages
strCon1 = ", "
strCon2 = " and "
'test for user defined 'joins'
If DispType = 29 Then
'only look for days text 'join' for display type 29
If InStr(1, YourDays, "^") <> 0 Then
strCon1 = Right(YourDays, Len(YourDays) - InStr(1, YourDays, "^"))
YourDays = Left(YourDays, InStr(1, YourDays, "^") - 1)
End If
End If
If DispType = 9 Or DispType = 19 Or DispType = 29 Then
'look for hours text 'join'
If InStr(1, YourHours, "^") <> 0 Then
strCon2 = Right(YourHours, Len(YourHours) - InStr(1, YourHours, "^"))
YourHours = Left(YourHours, InStr(1, YourHours, "^") - 1)
End If
End If
'*****************************************************************************************
'Check optional display text when user text is expected based on display type requested
'If Display Types 9 or 19 are used check for no user defined text (hours and minutes)
If DispType = 9 Or DispType = 19 Then
If Len(YourHours) = 0 Or Len(YourMinutes) = 0 Then
DispType = 1
End If
End If
'If Display Type 29 is used check for no user defined text (days, hours and minutes)
If DispType = 29 Then
If Len(YourDays) = 0 Or Len(YourHours) = 0 Or Len(YourMinutes) = 0 Then
DispType = 1
End If
End If
'*****************************************************************************************
'check and correct user defined text for singular forms & a space at the start
If DispType = 29 Then
'only test day text for display type 29
If Right(YourDays, 1) = "s" Then YourDays = Left(YourDays, Len(YourDays) - 1)
If Left(YourDays, 1) <> " " Then YourDays = " " & YourDays
End If
If DispType = 9 Or DispType = 19 Or DispType = 29 Then
If Right(YourHours, 1) = "s" Then YourHours = Left(YourHours, Len(YourHours) - 1)
If Right(YourMinutes, 1) = "s" Then YourMinutes = Left(YourMinutes, Len(YourMinutes) - 1)
If Left(YourHours, 1) <> " " Then YourHours = " " & YourHours
If Left(YourMinutes, 1) <> " " Then YourMinutes = " " & YourMinutes
End If
'*****************************************************************************************
'Calculate difference between start and end times/dates
'get date/time components
lngDay = Int(NdTm) - Int(StTm)
sngTime = (NdTm - Int(NdTm)) - (StTm - Int(StTm))
'*****************************************************************************************
'If DispType <10 then 'allow' an end time earlier than the start time and assume end is after midnight
If DispType < 10 And sngTime <= 0 Then
sngTime = (1 - StTm) + NdTm
Else
If sngTime < 0 Then
TimeMsg = "End < Start"
GoTo ErrEnd
End If
End If
'*****************************************************************************************
'if DispType <=10 then don't use date component, else calculate date difference and convert to hours
If DispType <= 10 Then
lngDy = 0
lngHr = Hour(sngTime)
intMn = Minute(sngTime)
If Second(sngTime) >= 30 Then intMn = intMn + 1
Else
'if display type >10 and <= 20 use date component but convert days to hours
'but first test for end time less than start time
If sngTime < 0 Then
blnNeg = True
End If
If blnNeg = False Then
If DispType <= 20 Then
lngDy = 0
lngHr = Hour(sngTime) + (lngDay * 24)
intMn = Minute(sngTime)
If Second(sngTime) >= 30 Then intMn = intMn + 1
Else
'display type >20 –display days as well as hours and minutes
lngDy = lngDay
lngHr = Hour(sngTime)
intMn = Minute(sngTime)
If Second(sngTime) >= 30 Then intMn = intMn + 1
End If
Else
'time portion difference is negative
sngTime = (1 / (24 * 60 * 60)) + sngTime
lngDay = lngDay - 1
If DispType <= 20 Then
lngDy = 0
lngHr = Hour(sngTime) + ((lngDay) * 24)
intMn = Minute(sngTime)
If Second(sngTime) >= 30 Then intMn = intMn + 1
Else
'display type >20 –display days as well as hours and minutes
lngDy = lngDay
lngHr = Hour(sngTime)
intMn = Minute(sngTime)
If Second(sngTime) >= 30 Then intMn = intMn + 1
End If
End If
End If
'*****************************************************************************************
'Text options selected depending on Display Type
Select Case DispType
Case 1, 11
strBaseHrTxt = "Hour": strBaseMnTxt = "Minute"
Case 2, 12
strBaseHrTxt = " Hour": strBaseMnTxt = " Minute"
Case 3, 13
strBaseHrTxt = "hour": strBaseMnTxt = "minute"
Case 4, 14
strBaseHrTxt = " hour": strBaseMnTxt = " minute"
Case 5, 15
strBaseHrTxt = "Hr": strBaseMnTxt = "Min"
Case 6, 16
strBaseHrTxt = " Hr": strBaseMnTxt = " Min"
Case 7, 17
strBaseHrTxt = "hr": strBaseMnTxt = "min"
Case 8, 18
strBaseHrTxt = " hr": strBaseMnTxt = " min"
Case 9, 19
strBaseHrTxt = YourHours: strBaseMnTxt = YourMinutes
Case 21
strBaseDyTxt = "Day": strBaseHrTxt = "Hour": strBaseMnTxt = "Minute"
Case 22
strBaseDyTxt = " Day": strBaseHrTxt = " Hour": strBaseMnTxt = " Minute"
Case 23
strBaseDyTxt = "day": strBaseHrTxt = "hour": strBaseMnTxt = "minute"
Case 24
strBaseDyTxt = " day": strBaseHrTxt = " hour": strBaseMnTxt = " minute"
Case 25
strBaseDyTxt = "Dy": strBaseHrTxt = "Hr": strBaseMnTxt = "Min"
Case 26
strBaseDyTxt = " Dy": strBaseHrTxt = " Hr": strBaseMnTxt = " Min"
Case 27
strBaseDyTxt = "dy": strBaseHrTxt = "hr": strBaseMnTxt = "min"
Case 28
strBaseDyTxt = " dy": strBaseHrTxt = " hr": strBaseMnTxt = " min"
Case 29
strBaseDyTxt = YourDays: strBaseHrTxt = YourHours: strBaseMnTxt = YourMinutes
Case Else
strBaseHrTxt = "Hour": strBaseMnTxt = "Minute"
End Select
'*****************************************************************************************
'Adjust the text for singular and plural
'Day text
If Right(strBaseDyTxt, 1) <> "." Then
If lngDy = 1 Then strDyTxt = strBaseDyTxt Else strDyTxt = strBaseDyTxt & "s "
Else
If lngDy = 1 Then strDyTxt = strBaseDyTxt Else strDyTxt = Left(strBaseDyTxt, Len(strBaseDyTxt) - 1) & "s. "
End If
'Hour text
If Right(strBaseHrTxt, 1) <> "." Then
If lngHr = 1 Then strHrTxt = strBaseHrTxt Else strHrTxt = strBaseHrTxt & "s "
Else
If lngHr = 1 Then strHrTxt = strBaseHrTxt Else strHrTxt = Left(strBaseHrTxt, Len(strBaseHrTxt) - 1) & "s. "
End If
'Minute text
If Right(strBaseMnTxt, 1) <> "." Then
If intMn = 1 Then strMnTxt = strBaseMnTxt Else strMnTxt = strBaseMnTxt & "s"
Else
If intMn = 1 Then strMnTxt = strBaseMnTxt Else strMnTxt = Left(strBaseMnTxt, Len(strBaseMnTxt) - 1) & "s. "
End If
'*****************************************************************************************
'Test for invalid date/time or special case 24 hours
If lngDy = 0 And lngHr = 0 And intMn = 0 And DispType <= 10 Then TimeMsg = "24" & strHrTxt: Exit Function
If lngDy = 0 And lngHr = 0 And intMn = 0 And DispType > 10 Then TimeMsg = CVErr(xlErrValue): GoTo ErrEnd
'*****************************************************************************************
'Put it all together as one text string
If DispType <= 20 Then
'without day display
If lngHr > 0 Then
If intMn > 0 Then
TimeMsg = Format(lngHr, "##0") & strHrTxt & strCon2 & Format(intMn, "#0") & strMnTxt
Else
'supress minutes
TimeMsg = Format(lngHr, "##0") & strHrTxt
End If
Else
TimeMsg = Format(intMn, "#0") & strMnTxt
End If
Else
'with day display
If lngDy > 0 Then
If intMn > 0 Then
TimeMsg = Format(lngDy, "##0") & strDyTxt & strCon1 & Format(lngHr, "##0") & strHrTxt & strCon2 & Format(intMn, "#0") & strMnTxt
Else
'supress minutes
TimeMsg = Format(lngDy, "##0") & strDyTxt & strCon2 & Format(lngHr, "##0") & strHrTxt
End If
Else
If lngHr > 0 Then
If intMn > 0 Then
TimeMsg = Format(lngHr, "##0") & strHrTxt & strCon2 & Format(intMn, "#0") & strMnTxt
Else
'supress minutes
TimeMsg = Format(lngHr, "##0") & strHrTxt
End If
Else
TimeMsg = Format(intMn, "#0") & strMnTxt
End If
End If
End If
Exit Function
'*****************************************************************************************
'Errors jump here
ErrHnd:
Err.Clear
TimeMsg = CVErr(xlErrNA)
ErrEnd:
End Function
'*****************************************************************************************
2. Enter Today's Date function
The function to enter today's date is a very short routine, which should be linked to the cell 'right–click' menu.
The routine automatically puts today's date in the active cell, and then formats the cell in the 'short date' format.
The 'short date format is set in the Control Panel's Regional and Language Options window. This means that the date will always
be entered in a standard format, and will not be subject to typo's or errors, such as reversing day and month.
To make the routine enter the date in the Windows 'Long Date' format, replace 'Short Date' with 'Long Date'. Alternatively to set
your own format, replace the line:
.Value = Format(Date, "Short Date")
with the following two lines:
.Value = Date
.NumberFormat = "dd/mmm/yyyy"
and adjust the date formatting codes as required. For a full list of codes, go to the VBA window, enter 'date formats' in the 'type a question for
help' box then select 'User-Defined Date/Time Formats (Format Function)'.
To see how to add a subroutine to a context menu, go to the context menu instructions.
Add the following code to a module –See How to add a routine to your copy of Excel
Sub Enter_Todays_Date()
'Paste today's date routine
'Version 1.01 July 2007
'© Humar Consulting 2007
'
'Sub to enter today's date into the active cell and format the cell in your PC's 'Short Date' format
'(see Regional and Language Options - Customize - Date Tab –Short Date)
'*****************************************************************************************
With ActiveCell
.Value = Format(Date, "Short Date")
End With
End Sub
'*****************************************************************************************
3. Day of the Week function
This function returns the day of the week for any date from 01 March 1704 to 31 December 2099.
It would be reasonably easy to extend the dates beyong 2099. Details of the calculations that go into this user defined function are
described in the section on Excel dates.
Add the following code to a module –See How to add a routine to your copy of Excel
Public Function DayOfWeek(DDate As Date) As String
'**************************************************************
'Function to return day of week for any date between 1704 and 2099
'© Humar Consulting Inc.
'Version 1.0 May 2008
'**************************************************************
Dim intYear As Integer
Dim strYear As String
Dim intCent As Integer
Dim intYear2 As Integer
Dim intMo As Integer
Dim strMonth As String
Dim intDay As Integer
Dim strDay As String
Dim intYrMod As Integer
Dim sngInter As Single
'**************************************************************
'get various parts of the date in text (string) and numeric (integer) formats
intYear = Year(DDate)
strYear = Format(intYear, "0000")
intCent = CInt(Left(strYear, 2))
intYear2 = CInt(Right(strYear, 2))
intMo = Month(DDate)
strMonth = Choose(intMo, "January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December")
intDay = Day(DDate)
strDay = Format(intDay, "00")
'**************************************************************
'return -1 if year is exactly divisible by 4, 100 or 400 and the month is January or February
'else return zero
If intYear Mod 4 = 0 And intYear Mod 100 = 0 And intYear Mod 400 = 0 And intMo < 3 Then
intYrMod = -1
Else
intYrMod = 0
End If
'**************************************************************
'add together the following:
'last two digits of the year divided by 4 (integer part only)
'day (1 to 31)
'a value based on the century - 19xx adds 0, 20xx adds 6
'a number based on the month – January is 1, February is 4
'intYrMod result (–1 or 0)
sngInter = Int(intYear2 / 4)
sngInter = sngInter + intDay
sngInter = sngInter + Choose(intCent - 16, 4, 2, 0, 6)
sngInter = sngInter + Choose(intMo, 1, 4, 4, 0, 2, 5, 0, 3, 6, 1, 4, 6)
sngInter = sngInter + intYrMod
sngInter = sngInter + intYear2
'**************************************************************
'modulus 7 division of the intermediate calculation
sngInter = sngInter Mod 7
'**************************************************************
'choose day of week based on the modulus 7 result
'have to add 1 as 'Choose' is not zero based
DayOfWeek = Choose(sngInter + 1, "Saturday", "Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday")
'**************************************************************
'put it all together as day text and date as text
'this could be changed to return only the day of the week, or a different
'format or order for the date
'a function such as Format(Date, "Short Date") could also be used for the date part
DayOfWeek = DayOfWeek & " " & strDay & " " & strMonth & " " & strYear
End Function
'**************************************************************
How to add a Function to your copy of Excel
Two types of function can be added to Excel –User Defined Functions (i.e., formulas), and Macros
User defined functions (UDFs) provide additional formulas, i.e., the = functions entered into cells. Macros or 'subroutines' are programs that perform functions
within Excel, and are not entered into cells. Macros are run independently of cell formulas, and may include dialog boxes that the user can enter
data into, or make choices, or macros can run without user interaction. Both UDFs and Macros are written inside Excel in VBA, a version of the
Visual Basic language. UDFs are enclosed by the Function ... End Function statements and Macros are enclosed by the Sub ... End Sub statements.
(Sub is short for subroutine).
UDFs and Macros are entered into 'Modules' which are attached to Excel workbooks, both visible and hidden workbooks, and the always hidden *.xla
Add–In Workbook. If you want a UDF or Macro to be used only with one workbook, the code can be written in
a 'Module' within the
specific workbook. The UDF or Macro is ONLY available when that workbook is open. The advantage is that the UDF or Macro is available if you
send the workbook to someone else. On the other hand UDFs and Macros that you want to use regularly need to be placed in a location that is
always available.
Always Available Code
There are two places where Macros can be located so that they are always available, but only one place for UDF's –
1. The hidden Excel spreadsheet Personal.xls, (Macros only) or
2. an Excel 'xla' add–in file. (Although an existing Excel xla can be used, a new xla file should be created and loaded specifically
for your projects. Most distributed xla files will be locked anyway).
The easiest method of adding Macros is to use the Personal.xls file.
To find the Personal .xls file, open Excel, then click on any cell and hit Alt + F11,
(the Alt key and function key 11, pressed at the same time).
If this doesn't work, go to Tools –Macro –Visual Basic Editor.
In the Project Explorer pane (usually on the left), select 'VBAproject (PERSONAL.XLS)', right click and select
'Insert', then Module (NOT class Module).
Clicking on 'Module' inserts a new module. The
module is given a default number, but you can give the module a friendly name in the properties section. If the Project Explorer pane
is not visible, click View –Project Explorer. To change the project name, the Properties window must be visible, and this can be
displayed using View –Properties Window.
Now, with a new Module, paste in the code, starting at the Public Function or Sub line, down to and including the End Function or End Sub statement.
If you are writing your own code, enter 'Option explicit' as the first line. Only one 'Option Explicit' statement is required per module even if
more than one function or subroutine is entered in the module.
The Option Explicit statement instructs visual basic to check all the variables used in the code, ensuring that there is a Dim statement for each one.
This reduces the risk of mistyping a variable name. Without using Option Explicit you could accidently enter a variable called 'FormatOn' as
'FornatOn', for example, and Visual Basic would create two variables, with no link between them, and your program would not work as expected.
For a function enter 'Function Unique Name ()', e.g., Function My_Special_Calc ()
or Sub My_Special_Macro (). Note that spaces are not allowed in the name. The end statement 'End Function' or 'End Sub' will be added automatically.
If you are writing your own code, don't forget to start with a brief description, and a date or version number, and include comments in your code
to remind you of what each section does or how it is intended to work. This will help later when either fixing a bug, extending your program's
functions or reusing part of the code in another UDF or Macro. Comments start with an apostrophe '.
No code goes before the Option Explicit statement, and in general, no other information goes between the Option Explicit statement and the start
of the first function or subroutine. (Variables that are to be shared between different functions or subroutines which are included in the same module
are placed here with a Dim statement, e.g., Dim intCommonCounter As Integer. This identifies intCommonCounter as a variable of type 'integer'.
If a variable is used only within one function, then the Dim statement is usually put near the top of the code for that function, after the initial comments.
When variables are defined in each function or subroutine, the names can be reused, such as Dim N As Integer could be used as a 'For...Next' counter,
in all your UDF's and Macro's. The value a variable takes in one function does not affect the value of a variable with the same name in another function.
OK, so you can now put code into a module. Copy the code on this page, for the function you want to use –complete from Function to End Function or Sub to
End Sub statements. Paste the code into the module, then save the project, either using the File –Save from the menu bar or Alt plus F followed
by the S key. Remember that the Microsoft Visual Basic section of Excel does NOT prompt you to save changes made to an Add–In (.xla)
file, so you must Save before quitting. If you add code to Personal.xls you will be prompted to save changes before closing, but it is better
to save it yourself, as well as saving your work at intervals, just in case the Visual Basic module crashes –rare, but it does
happen –I know from personal experience!
Code Available to a Specific Worksheet
To add a UDF or Macro to just one Workbook, open & Save an existing or new workbook. Using Alt plus fn11 or Tools –Macro –
Visual Basic Editor, open the Visual Basic editor, and in the project explorer pane select the workbook you have just opened, (Its name will
be preceded by VBAproject. Right click, and as described above, create a new module. Enter your code as previously
described, save the Visual Basic project (File –Save from the menu), then close the Visual Basic Window and in the Excel Window save your
workbook. The UDF or Macro you wrote is now attached to the workbook and will only be available when that workbook is opened. A proviso to this, is that
if you added an icon or menu item to run your macro, Excel will attempt to open the worksheet if you click on the icon or menu item. If the worksheet
isn't in the location originally used, the attempt to open it will fail. Icons on toolbars and menu items are saved with Excel and not with the workbook
so the Icon or menu item will be there when you open Excel, even if you haven't opened the workbook with the code attached.
If you send the workbook to someone else, they will have the code, but any icon or menu item you created will not be available to them, unless you
have added additional code to make this happen. (This is beyond the scope of this item, but as usual you can find web pages which describe how to
programmatically add toolbar icons, menu items and right-click context menu items).
Code in an Excel Add–In
Go to this section on How to create an Add–In hidden workbook. If you need more information, use Google to find one of several websites that have this information. Microsoft also provides a description.
Back to Top of Page
How to Create an Add–In Hidden Workbook to Store Your Functions and Macros
If you want your functions (UDF's) or Macros to always be available, you can create an Add–In hidden workbook
The benefit is that the UDF's and Macros will always be available to you when you open Excel. The downside is that the UDF's and Macros
will not be available to another user, if you send them a regular worksheet that uses one of your UDF's or Macros. You can of course
send them the Add–In as well.
Another option is to keep all your UDF's and Macros in your own Add–In hidden workbook, and if you want to share a workbook
with someone else, just copy the Function or Macro to a new module in the workbook you are sending.
Go here to see how to add a module to a regular workbook.
Create a New Add–In Hidden Workbook
Open Excel, and create a new regular workbook.
Save the workbook with a friendly name, e.g., MyOwnFunctions
You can save the workbook using 'File – Save As',clicking on the 'Save as type' drop–down and selecting Microsoft Office
Excel Add–In (*.xla) option. The file can be saved anywhere on you own PC, but you might as well use Excel's default location.
The root varies a bit depending on the version of Windows. Once you select the *xla file type, the Save dialog box should move directly
to the default location for Excel Add–Ins. If it doesn't you can find it yourself:
In XP, assuming XP is loaded on drive C, navigate to:
C:\Documents and Settings\your user name\Application Data\Microsoft\AddIns\
If you are not using XP, open a command window and enter "cd %HOMEPATH%". This will give you the drive letter and path up to and including
your user name. Then follow the remainder of the path to the AddIns directory.
Once you have saved your new file, close Excel, then re–open it. Go to the 'Tools – AddIns... menu item.
This will open a dialog box. If you saved your new xla file to the default AddIns directory, the file will be listed in this dialog box.
Check the box next to the name. If you saved the file somewhere else, use the Browse button to find it and follow the instructions
to load it.
Your Add–In workbook will now load every time you open your copy of Excel.
Use Your Add–In
The .xla Add–In workbook will not open like a normal workbook,
as it is hidden. From Excel open the VBA window (Alt+function key 11 or use menu: Tools – Macro – Visual Basic Editor),
and the workbook will be shown in the 'Project Explorer' window. Ctrl+R will open the Explorer window if it isn't visible.
Double click on the filename. There will be a 'Properties' box as well, but if it isn't visible hit the function key F4,
(your cursor must be in the explorer box for this to work).
OK, so you now have an xla file that you can use to store your UDF's and Macros. Remember to add a new 'Module' to store them in,
(don't use 'Class Module'). You can create several modules, so that you can logically group functions together. It makes it easier to
find your code later, but it doesn't alter the way they work. I store all my text handling functions in a module named 'Text' !!!
To open a new module, put your cursor on the name of the Add–In in the explorer window, then right click or use the Insert menu,
and select Module.
To give the module a friendly name, you have to click on the new module name, typically 'Module1' in the Explorer box, then change
the name in the Properties box.
Don't forget to save the change to your Add–In file, either from the menu: File – Save or using alt+F followed by S.
Excel does NOT prompt you to save changes made to an Add–In file when you close Excel – so get in the habit of saving your
file regularly while you are workinng on it.
Like any of your files, don't forget to make backups of your new Add–In workbook either at regular intervals or after
any significant changes. Losing a workbook with your own user defined functions or Macros is NOT fun.
In the Modules you create you can store user defined functions and Macros. Remember to put 'Option Explicit' as the first line of
each module. This reduces the risk of programming errors such as using a variable named 'counter1', and later in the code using
'counter01'. As Option explicit requires you to have a Dim statement for each variable, if you had entered: 'Dim counter1 as Integer'
then Option Explicit would recognize 'counter01' as different and not defined, and give you a warning when you either test compile
the code (Use the menu item Debug - Compile VBAProject), or try and run it.
Store Data In Your Add–In
Add–In workbooks are hidden and even in the VBA window you can't see the worksheets in them. If you look in the Explorer
window, and click on the '+' next to the filename, you will see that there are worksheets present. If you want to store data such as
icon images or information that your UDF will use, you can make the worksheets visible as follows:
Click on the 'This Workbook' item under
your new Add–In, then in the Properties box, find the 'IsAddIn' item. On the right side, click on 'True' and from the drop–down
select 'False'. Move back to the main Excel window and the worksheets will now be visible.
When done, just change the 'IsAddIn' item back to true.
How to create a Toolbar Icon or a Menu Item to Run a Macro
When you have added the code for one or more macros to Personal.xls, another workbook or an xla add–in, you need an easy way to access the macro. There are three options:
- 1. Add an Icon
- 2. Add a Menu Item
- 3. Add a Context Menu Item
- 3. Put User–defined Functions in Groups
Adding an Icon
The best way is to put one or more icons on one of your toolbars, and link the icons to your macros. If you don't use
Pesonal.xls as the location, it may be harder to make the link. Excel makes it easy to link to Macros in Personal.xls.
With any Excel workbook open, even a blank workbook,
right click with the mouse anywhere on a toolbar.
At the bottom of the menu that opens–up, click on Customize,
and select the Commands Tab on the dialog box that opened.
In the left pane, select Macros, and then in the right pane click on Custom Button if you want an Icon, or Custom Menu if you want the link
to be in a menu.
For an icon, drag the 'smiley' icon onto a toolbar, at the position you want it. Don't close the Customize dialog box. Right click on
the new smiley icon on the toolbar, and select the last item, 'Assign Macro'.
Then, from the dialog box that opens, select the name of your macro, from the list shown –
most, if not all, of the names will be preceded by Personal.xls. If you have attached a macro to an individual workbook,
and that workbook is open, then the macro name will be shown without any filename in front of it.
Click on the Macro you want linked to the button. Then click OK.
If your code is in an xla Add–in, the name of your macro will not be in the list, and you will have to enter it yourself.
If you have just created the new macro, Excel will not be able to find it, until Excel has been closed and re–opened.
(Don't forget to save your code before closing the Visual Basic window, as there is no 'save' warning when closing Add–in's
that have been altered).
When entering the name of a new macro for your icon, use the full filename, e.g., MyAddIns.xla, followed by an '!' character
(no spaces), then the name of the module containing your new code, e.g., MergeCellRoutines, followed by ".", again, no spaces,
and finally the name of the macro as it appears after the word 'Sub'. The full text for a macro called MergeByRow written in a module
called MergeCellsRoutines, in an Add–in file called MyAddIns.xla would be MyAddIns.xla!MergeCellsRoutines.MergeByRow
Click OK. Keep the Customize dialog box open, and right click again on the new icon, select Assign Macro, and if Excel recognized
the name you entered, it will now show–up without the Add–In filename, e.g., MergeCellsRoutines.MergeByRow
If the xla filename is still shown, it is likely that there is an error, and Excel has not found your Macro. Remember, that Excel has to
be shut down and re–started before Excel can link to a new macro.
After closing the Customize dialog box, clicking on your new icon will run your new macro, (subroutine code).
You can stop here, but to make a good job of it, there are two more steps:
1. Give the icon a useful name –Open the Customize dialog box by right–clicking anywhere on a toolbar, then, right click
on the icon, and in the name box enter a 'usefull' name, e.g., Merge by Row.
If you put an & before a letter in the name, that letter can be used with the Alt key, but it's best left without an & at this
stage, to avoid conflicts with other icons.
2. Give the icon a relevant image. Right click on the icon again and select Edit button image to draw your own icon image, or select
Change button image, to select from a short list of images included with Excel. (You can also select an existing icon image first,
either from another icon on your toolbars, or from the short list of images, and then click Edit button image and edit it to your
liking).
Finally close the Customize dialog box and clicking your new icon should run the macro.
If you have added a subroutine (macro) to a module in any workbook or add–in, and the macro either doesn't show
or the name you entered isn't recognized, then save your VBA code, and workbook, then close and exit Excel and Windows. Re–
open Excel and right–click on a toolbar and try again. Your new macro should now be recognized. If not, check the spelling of
the filename, module and subroutine, and make sure the '!' and '.' are included, as described above.
Adding a Menu Item
To add a menu item instead of an icon, first decide which drop–down menu you are going to add it to. Then Right click on a toolbar, and as before, select Customize, Command Tab and the Macros item. Now click on the drop–down menu you want to use, and then in the right pane, select Custom Menu Item.
Drag this across to the menu you opened and move it to the position in the list,
you want –a bar denotes the position. Before closing the menu, right click on your new item and link it to your new macro,
then give it a name. Both these steps are the same as described for a toolbar icon. Close the Customize dialog box, and you are
ready to use your new menu item.
Remember that you can only link macros, i.e., code that starts with Sub() and ends with End Sub. You can't link functions
(Function()...End Function).
In the image above, you can see that I have added a menu item called 'Merge Cells in Row' subroutine (macro), to the Format –Row
Sub menu. This runs the Sub MergeByRow () routine.
Add a Context Menu Item
Context menus are usually accessed by a right–click on an object. Foe example when a cell is selected, right–clicking on
the cell brings up a menu that is relevant to 'cells', i.e., it is in the right context!
To add a subroutine to a context menu is a bit more involved and can only be done by writing some more VBA code. There is also the risk
that your menu item gets added over and over again, so care is needed when writing the code, so that multiple copies aren't created.
The code to add a context menu goes into a 'ThisWorkbook' item, not a Modue. Look in the VBA object browser, and find the
VBA Project (PERSONAL.XLS) item. click on the + next to Microsoft Excel Objects. There will be an item named 'ThisWorkbook'. This is where
code general to the whole workbook is placed. 'ThisWorkbook' is an item associated with every workbook, and with all xla Add–Ins.
Which of the 'ThisWorkbook' items to use depends on when you want the context menu to appear. If you want the context menu to only occur
when one specific workbook is open, then use 'ThisWorkbook' attached to the specific workbook. If you want the context menu to be
available every time you open Excel. use the 'ThisWorkbook' attached to Personal.xls. If you have written your subroutines in an
xla Add–In, use the 'ThisWorkbook' attached to the xla.
The code used is the same whichever route you choose. In general you want to use the workbook or Add–In which contains the
subroutine or subroutines that will be added to the context menu(s).
The code is in three sections:
1. Code to check if the context menu is already present, and remove it!
2. Code to add the context menu
3. Code to remove the context menu when the workbook or Add–In is closed
It may seem like overkill to have both items 1 and 3, but 1 is present in–case Excel (or Windows) quits or crashes
so that the context menus are not removed as planned.
The code in 1. and 2. are associated with the 'Open' action of the workbook, and the code in 3. is associated with
the 'BeforeClose' action of the workbook. (Workbooks have actions which can be used to trigger code).
The code to add consists of creating a new object –a 'Control' which is part of a context menu. In the following code snippet
the new control has been called 'objNewControlMR'. It is initially setup with a Dim command, but is only really created when the Set
command is used. At this point 'objNewCommandMR' becomes a real control object that you can manipulate, and in this example you
can give it a name (Caption), assign an Action for when it is clicked, (run the MergeByRow macro / subroutine), and specify whether
the item is in a new group, i.e., has a horizontal line before it, to separate it from other items in the menu.
When you create the menu item using 'Set', you can specify the position using the 'Before' parameter. The command would be:
Set NewControlMR = Application.CommandBars("Cell").Controls.Add (Before:=1). In this case 'before 1' means it will now be first
in the list. To place it elsewhere you need to know the index number of the menu item that it will go 'before'. (Note that controls have
both an ID number and an Index number. It is the index number that denotes it's position).
Here is the code to enter, note that if adding several controls you would group all the 'Dim' statements together, then have all the 'Set' and
'With ... End With' code together. This is not essential, but it follows the way that most code is written with the 'Dim' statements
together at the start of the program.
Option Explicit
Private Sub Workbook_Open()
On Error Resume Next
'********************************************************
'Use Dim to tell VBA that it will be handling a new Command Bar Button (menu item). It also makes VBA's 'intellisense' work, because
you have 'told' VBA what objNewCtrlMR is, and VBA will now know what commands are available.
Dim objNewCtrlMR As CommandBarButton
'********************************************************
'Before adding a new menu item, make sure that it isn't already there. If it is –remove it!
'The On Error Resume Next instruction ensures that this code won't stop the whole program if it can't find a "Merge Cells by Row"
menu item.
Application.CommandBars("Cell").Controls("Merge Cells by Row").Delete
'********************************************************
'Set will create the new menu item, then 'with' the new menu item, give it some features.
Set NewControlMR = Application.CommandBars("Cell").Controls.Add
With NewControlMR
.Caption = "Merge Cells by Row"
.OnAction = "Formats.MergeByRow"
.BeginGroup = True
End With
End Sub
Adding Functions to Groups
When you are choosing a function you have the option of searching within groups of functions, using the Insert Function dialog, as shown here.
By default all User–defined functions go into a group called 'User–defined'. It is possible to add your UDF's
to relevant groups, for example add the three text functions, (XtndLeft, XtndRight and XtndMid) to the Text functions.
This is basically done by the following line of code:
Application.MacroOptions Macro:="Module1.XtndLeft", Category:=7
where 7 is the text group.
In the following image a user defined function (DyHrWr), which is concerned with time, has been added to the Date & Time group,
and it shows up with the other Date & Time functions.
Click for the full list, and also note that you can create your
own groups and then add functions to these new groups.
Using this code is not quite straightforward, as there are different requirements for when your UDF's are in an xla Add–In, in
an ordinary workbook, or in the hidden workbook Personal.xls.
1. In an ordinary workbook.
This is the most straightforward. Enter the line of code (modified for the name(s) of the UDFs and the groups you want each one
in) in the 'ThisWorkbook' item in the subroutine called 'Workbook_Open'. If this Subroutine isn't there, just enter 'Private
Sub Workbook_Open ()', click enter and 'End Sub' will appear. Enter the code between the Open and the End Sub statements.
2. In an xla Add–In file.
As xla's are hidden, the command 'Application.MacroOptions' does not work inside the Open_Workbook subroutine,
instead enter the code inside a subroutine called 'Private Sub Workbook_AddinInstall()', in the 'ThisWorkbook' item.
3. In Personal.xls, or any hidden workbook.
The command 'Application.MacroOptions' does not work when the workbook, and hence the function is hidden. Excel gives the
unhelpful warning that the Macro must be unhidden.
For hidden workbooks, enter the code in the Workbook_Open sub, in the 'ThisWorkbook' item, but then surround it with two commands,
one to unhide the workbook and one to re–hide afterwards. The code looks like this:
Private Sub Workbook_Open()
Windows("PERSONAL.XLS").Visible = True
Application.MacroOptions Macro:=Module1.XtndLeft", Category:=7
Windows("PERSONAL.XLS").Visible = False
End Sub
The function name is preceded by the name of the module it is stored in. In the example, the function is 'XtndLeft' and the code for it is in Module1. (Don't forget the '.' after the Module name).
Back to Top of Page