Automate Excel

The following function will find the nth word in a string:

Function Find_nth_word(Phrase As String, n As Integer) As String
Dim Current_Pos As Long
Dim Length_of_String As Integer
Dim Current_Word_No As Integer
Find_nth_word = ""
Current_Word_No = 1
'Remove Leading Spaces
Phrase = Trim(Phrase)
Length_of_String = Len(Phrase)
For Current_Pos = 1 To Length_of_String
    If (Current_Word_No = n) Then
        Find_nth_word = Find_nth_word & Mid(Phrase, Current_Pos, 1)
    End If

    If (Mid(Phrase, Current_Pos, 1) = " ") Then
     Current_Word_No = Current_Word_No + 1
    End If
Next Current_Pos
'Remove the rightmost space
Find_nth_word = Trim(Find_nth_word)
End Function

It needs two arguments – the phrase that is to be searched and the word number:

Find_nth_word(“Automateexcel ls the worlds favourite Excel site”,4)

Will return “world”.

A blank is returned if the number of words in the phrase is less than the word number specified.

So: Find_nth_word(“Automateexcel ls the worlds favourite Excel site”,12)
Will return blank as there are not 12 words in the phrase “Automateexcel ls the worlds favourite Excel site”.

Download

To download the .XLSM file from this article, click here

The following code works opening a workbook. It automatically adds a new sheet and labels it with the date. It also checks to see that the sheet doesn’t already exist – to allow for the possibility of it being opened more than once a day.

This code makes use of the Workbook Open Event and must be placed in the workbook module under the “Open work Book” event. The function Sheet_Exist must be placed in a module and this checks whether or not the sheet exists:

Private Sub Workbook_Open()
Dim New_Sheet_Name As String
New_Sheet_Name = Format(Now(), "dd-mm-yy")
If Sheet_Exists(New_Sheet_Name) = False Then
    With Workbook
        Worksheets.Add().Name = New_Sheet_Name
    End With
End If
Save
End Sub

Function Sheet_Exists(WorkSheet_Name As String) As Boolean
Dim Work_sheet As Worksheet
Sheet_Exists = False
For Each Work_sheet In ThisWorkbook.Worksheets
      If Work_sheet.Name = WorkSheet_Name Then
        Sheet_Exists = True
    End If
   Next
End Function

To download the .XLSM file for this tutorial, click here

The following code will prompt the user for the name of a workbook. It will then create and save a new
workbook with the same name.

Private Sub CommandButton1_Click()
Dim Workbook_Name As String
Dim New_Workbook As Workbook
Set New_Workbook = Nothing
Workbook_Name = InputBox(Prompt:="Workbook Name.", Title:="Enter the WorkBook Name :")
Set New_Workbook = Workbooks.Add
With New_Workbook
.Activate
.SaveAs Workbook_Name
End With

End Sub

To download the .XLSM file for this article, click here

The following UDF will return the formulae for a given cell reference:

Function Show_Cell_Formulae(Cell As Range) As String
    Show_Cell_Formulae = "Cell " & Cell.Address & " has the formulae : ' " & Cell.Formula & " '"
End Function

So if we have:

Where the cell B7 has the formulae : ‘=MAX(B5:G5) then we can type in another cell:
B9 = Show_Cell_Formulae(b7)

And we get a text string with the cell reference and the formulae contained within it.

To download the .XLSM file for this article, click here

Imagine that we have the following 2 lists each consisting of 3 columns of data:

And we need to find those items that are in List 1 that are in List 2. However ALL 3 columns of data must match for items to be in both lists. One way would be to construct a comprehensive IF function. However this could get to be a messy formulae.

An alternative would be to construct some helper columns . Helper columns are additional columns that can reduce the need for complex or cumbersome formulae. In this case the Helper columns are the individual list items concatenated into a single string.

So in cell D6 we have:
D6 = A6&” “&B6&” “&C6 and:
I6 = F6&” “&G6&” “&H6
And then copy down:

And then we can put in column L:
=IF(ISNUMBER(MATCH(I6,$D$6:$D$16,0)),”MATCH”,”")

So when there is a match we between the item in Column I and Column D, we get the word “MATCH” appearing – otherwise we get blank space:

To download the .XLSX file for this article, click here

This is the opposite tutorial of the Converting a Single Row Vector into a Matrix tutorial.

The following function will take a range as a matrix and convert it to a single column vector:

Option Explicit
Function Create_Vector(Matrix_Range As Range) As Variant
Dim No_of_Cols As Integer, No_Of_Rows As Integer
Dim i As Integer
Dim j As Integer
Dim Cell
No_of_Cols = Matrix_Range.Columns.Count
No_Of_Rows = Matrix_Range.Rows.Count
ReDim Temp_Array(No_of_Cols * No_Of_Rows)
'Eliminate NULL Conditions
If Matrix_Range Is Nothing Then Exit Function
If No_of_Cols = 0 Then Exit Function
If No_Of_Rows = 0 Then Exit Function

For j = 1 To No_Of_Rows
    For i = 0 To No_of_Cols - 1
    Temp_Array((i * No_Of_Rows) + j) = Matrix_Range.Cells(j, i + 1)
    Next i
Next j
Create_Vector = Temp_Array
End Function

So for example the vector:

Will become:

Where we have used the following subroutine to print out the vector:

Private Sub CommandButton1_Click()
Dim Vector
Dim k As Integer
Vector = Create_Vector(Sheets("Sheet1").Range("A4:D8"))
For k = 1 To UBound(Vector)
        Sheets("Sheet1").Range("B20").Offset(k, 1).Value = Vector(k)
Next k
End Sub

Note that these routines work on both numbers and text.

To download the .XLSM file from this tutorial, click here.

Imagine that we have a list of names such as:

And we want to give each one a unique identifier:

So that the first name Bob has the identifier 1, and the next Mark has the identifier 2. This can be achieved by the following process.

We assign Bob (i.e the first person in the list) with an identifier 1:

And then we insert the following formulae in the next cell below this and copy down:

=IF(ISNA(MATCH(B7,B6:$B$6,0)),MAX(C6:$C$6)+1,VLOOKUP(B7,B6:$C$6,2,FALSE))

So:

The formulae works by looking for an occurrence of the name to date. If it doesn’t exist then it finds the maximum value of the identifier to date and adds one to give a new identifier. If a name does exist then a lookup is done to find the identifier for that name.

If more names are added at the bottom or in the middle and the formulae copies down, it still gives a distinct identifier.

Excel’s SUBSTITUTE function allows us to substitute part of a string with another part:

SUBSTITUTE(String,”Old Text”,”New Text”,occurrence”)

Where:
• String is the string that we are working with
• “Old Text” is the text that we want to eliminate
• “New Text” is the text that we want to incorporate
• Occurrence is which instance of the old text we wish to replace

Lets consider the following 3 examples:

Looking at cell B3, we want to replace the word “sick” with “large”. We can use the following expression:

=SUBSTITUTE(B3,”sick”,”large”,1)

If the text that we want to replace occurs more than once then we need to specify the instance that we mean. In the second example, we have two occurences of the word “old”. So if we want to change second instance to the word “grey” then we have to use:

=SUBSTITUTE(B4,”old”,”grey”,2)

Note that if the occurrence is not specified then all instances are replaced. So:

=SUBSTITUTE(B4,”old”,”grey”)

Would get rid of all instances of the word “old” and replace them with the word “grey”. Note that if the old text cannot be found then the string is unchanged. So looking at the last example:

=SUBSTITUTE(B5,”black”,”grey”,1)

Means that we try and replace the word “black” with the word “grey”. However, as “black” does not occur the original string remained unchanged:

To download the .XLSX file from this article, click here

This is the opposite tutorial of the Convert Matrix to Vector tutorial.

The following function takes a single row vector and converts into a matrix:

Function Create_Matrix(Vector_Range As Range, No_Of_Cols_in_output As Integer, No_of_Rows_in_output As Integer) As Variant
ReDim Temp_Array(No_Of_Cols_in_output, No_of_Rows_in_output)
Dim No_Of_Elements_In_Vector As Integer
Dim Col_Count As Integer, Row_Count As Integer
Dim Cell
No_Of_Elements_In_Vector = Vector_Range.Rows.Count
'Eliminate NULL Conditions
If Vector_Range Is Nothing Then Exit Function
If No_Of_Cols_in_output = 0 Then Exit Function
If No_of_Rows_in_output = 0 Then Exit Function
If No_Of_Elements_In_Vector = 0 Then Exit Function
For Col_Count = 1 To No_Of_Cols_in_output
    For Row_Count = 1 To No_of_Rows_in_output
    Temp_Array(Col_Count, Row_Count) = Vector_Range.Cells(((No_of_Rows_in_output) * (Col_Count - 1) + Row_Count), 1)
        Next Row_Count
Next Col_Count
Create_Matrix = Temp_Array
End Function

The function takes 3 arguments:
• The range of the initial vector
• The number of rows required in the matrix
• The number of columns required in the matrix

So if we have:

Then we can call our function:

Convert_to_matrix(c7:c16,2,5)

Where:

1. c7:c16 is the matrix range
2. 2 is the number of rows required in the matrix
3. 5 is the number of columns required

And we get:

To download the .XLSM file from this function, click here.

The following function will return the Maximum Value in each Column in a Range:

Function Max_Each_Column(Data_Range As Range) As Variant
    Dim TempArray() As Double, i As Long
        If Data_Range Is Nothing Then Exit Function
        With Data_Range
        ReDim TempArray(1 To .Columns.Count)
        For i = 1 To .Columns.Count
            TempArray(i) = Application.Max(.Columns(i))
        Next
    End With
        Max_Each_Column = TempArray
End Function

We can use a subroutine like the following to display the results:

Private Sub CommandButton1_Click()
Dim Answer As Variant
Dim No_of_Cols As Integer
Dim i As Integer
No_of_Cols = Range("B5:G27").Columns.Count
ReDim Answer(No_of_Cols)
Answer = Max_Each_Column(Sheets("Sheet1").Range("B5:g27"))

For i = 1 To No_of_Cols
MsgBox Answer(i)
Next i
End Sub

So:

Will return 990,907, 992, 976 ,988 and 873 for each of the above columns.
[SPECIAL THANKS TO MIKE RICKSON FOR RESOLVING THE FINERIES OF ARRAYS WITHIN UDF’S ]

The following tutorial will describe how to create a bar chart using VBA.

Steps:

1. Enter the VBA project window by right clicking on a sheet name and selecting “View Code” or by selecting “ALT, F11”.

2. On the right hand side, right click on your project name and select inset “module”.

3. Copy and paste the following code into the new module you just created:

 Sub MakeChart()
              Dim myRange As Range
                        Set myRange = Application.InputBox _
                                    (Prompt:="Select chart inputs", Type:=8)
                                                Charts.Add
                                    ActiveChart.ChartType = xlColumnClustered
                        ActiveChart.SetSourceData Source:=myRange, _
            PlotBy:=xlColumns
    ActiveChart.Location Where:=xlLocationAsNewSheet
End Sub

4. Click on the save button.

5. Click on the little Excel icon on the top right under the “File” menu to exit the VBA project window and to return to Excel.

6. Next run the macro by pressing “Alt F8” to bring up the list of macro’s available and selecting “MakeChart”.

A simple way to add a comment to a formula for later reference is to add the following to the formula N+(“YOUR COMMENT”). By way of an example, =SUM(A2:A4)+N(“This is”).

The following Subroutine will delete each row in a range where the value in Column A begins with a prescribed piece of text:

Sub Delete_Rows(Data_range As Range, Text As String)
Dim Row_Counter As Integer
For Row_Counter = Data_range.Rows.Count To 1 Step -1
If Data_range Is Nothing Then
    			Exit Sub
End If
If UCase(Left(Data_range.Cells(Row_Counter, 1).Value, Len(Text))) = UCase(Text) Then
    		Data_range.Cells(Row_Counter, 1).EntireRow.Delete
End If
Next Row_Counter

End Sub

For example Delete_Rows(Sheets(“Sheet1”).Range(“A1:E23”,”Dog”) will delete all the rows in the range A1:E23 where the value in Column A begins with the word “Dog”. Note the use of Ucase means that the formulae is case INSENSITIVE i.e cells that begin with any of DOG, Dog, DoG or dog will all be deleted.

Will become:

To download the related files with this article:
- deleting multiples.xlsm
- deleting multiples.xlsx

Consider the following two lists:

And that we want to see which items from column A are in Column B. This can be achieved by the MATCH function in conjunction with ISNUMBER .

The MATCH function has the following syntax:

MATCH(A6,C4:C13,0)

And this will return the position of the value cell A6 in the range C4:C13 – the “0” is for an exact match. So this will return the number 2 – as “Ship” (the value in cell A6) has position 2 in the range C4:C13. If an exact match can’t be found then an N/A# is returned.

Combining this with a ISNUMBER function we have:

ISNUMBER(MATCH(A6,C4:C13,0))

Will return TRUE when there is a MATCH and a FALSE when there is no MATCH.

So we can put the following in cell B4 and copy down:

IF(ISNUMBER(MATCH(A4$C$4:$C$13,0)),”MATCH”,””)

This will return the expression “MATCH” when the value in Column A can be found in Column B

To download the .XLSX file from this tutorial, click here.

The following subroutine will highlight all the duplicate values in range in yellow. It does not matter whether the values are text or numbers. It uses Excel’s COUNTIF function to count up the duplicates and then sets the colour to yellow:

Sub Highlight_Duplicates(Values As Range)
Dim Cell

For Each Cell In Values
    If WorksheetFunction.CountIf(Values, Cell.Value) > 1 Then
        Cell.Interior.ColorIndex = 6
    End If

Next Cell
End Sub

And we have invoked it using a the click event:

Private Sub CommandButton1_Click()
Highlight_Duplicates (Sheets("Sheet1").Range("C10:F14"))

End Sub

and then if we press the button we see all the duplicates:

To download the .XLS file with this tutorial, click here

The following routine will look at the contents of a single column set up Excel worksheets within the current workbook with these names. It makes a call to another function to see if a sheet with that name already exists, and if so the sheet isn’t created.

Private Sub CommandButton1_Click()

Call CreateWorksheets(Sheets("Sheet2").Range("A1:a10"))

End Sub

Sub CreateWorksheets(Names_Of_Sheets As Range)
Dim No_Of_Sheets_to_be_Added As Integer
Dim Sheet_Name As String
Dim i As Integer

No_Of_Sheets_to_be_Added = Names_Of_Sheets.Rows.Count

For i = 1 To No_Of_Sheets_to_be_Added

Sheet_Name = Names_Of_Sheets.Cells(i, 1).Value

'Only add sheet if it doesn't exist already and the name is longer than zero characters

If (Sheet_Exists(Sheet_Name) = False) And (Sheet_Name <> "") Then
    Worksheets.Add().Name = Sheet_Name
End If

Next i

End Sub

Function Sheet_Exists(WorkSheet_Name As String) As Boolean
Dim Work_sheet As Worksheet

Sheet_Exists = False

For Each Work_sheet In ThisWorkbook.Worksheets

    If Work_sheet.Name = WorkSheet_Name Then
        Sheet_Exists = True
    End If

Next

End Function

So if we have the following text in cells A1:A30 in Sheet 2:

Then the following sheets will be created:

Note that although “Dog” appears twice, only one sheet is created.

To download the .XLS file for this tutorial, click here.

The following function will examine a range of Excel cells and return the number that fall within a specified range:

Function Count_Selected_Cells(Data_Range As Range, Min As Double, Max As Double) As Integer
Dim Cell
Count_Selected_Cells = 0#
For Each Cell In Data_Range
    If ((Cell.Value >= Min) And (Cell.Value <= Max)) Then
        Count_Selected_Cells = Count_Selected_Cells + 1
    End If

Next Cell
End Function

It can be used as:

=Count_Selected_Cells(B5:F14,12,50)

Will return the number of cells having values between 12 and 50 in the range B5:F14:

To download the .XLSM file from the article, click here

The following function evaluates Acronyms from strings i.e it concatenates the first letter in every word in a string. E.g “trees are green” becomes “TAG”.

The routine traverses every character in a string and if it is a space then it takes the next character in the string. Before evaluating the string, it removes all trailing and duplicate spaces.

Function Acroymn (Original_String As String) As String
Dim Trimmed_String As String
Dim Length As Integer
Dim Pos As Integer
Trimmed_String = Application.WorksheetFunction.Trim(Original_String)

'work out the length of the string

Length = Len(Trimmed_String)

Acroymn = UCase(Left(Trimmed_String, 1))
For Pos = 2 To Length - 1
If (Mid(Trimmed_String, Pos, 1) = " ") Then
Acroymn = Acroymn & UCase(Mid(Trimmed_String, Pos + 1, 1))
End If
Next Pos
End Function

So for example :
Acroymn (“British Broadcasting Corporation”) gives BBC
Acroymn (“Funky”) gives F
Acroymn (“”) gives NULL

To download the .XLSM file from the article, click here

Consider the following data table:

The standard Vlookup function within Excel has the following format:

VLOOKUP(“”Mark”, B6:G12”,2,FALSE)

Which will return “Brown”.

However, what about if we wanted to look up on 2 or more columns e.g the first name, last name and the age in the above table ? The following UDF allows us to do this:

Function ThreeParameterVlookup(Data_Range As Range, Col As Integer, Parameter1 As Variant, Parameter2 As Variant, Parameter3 As Variant) As Variant
'Declare Variables
Dim Cell
Dim Current_Row As Integer
Dim No_Of_Rows_in_Range As Integer
Dim No_of_Cols_in_Range As Integer
Dim Matching_Row As Integer

'set answer to N/A by default
ThreeParameterVlookup = CVErr(xlErrNA)
Matching_Row = 0
Current_Row = 1

No_Of_Rows_in_Range = Data_Range.Rows.Count
No_of_Cols_in_Range = Data_Range.Columns.Count

'Check if Col is greater than number of columns in range

If (Col > No_of_Cols_in_Range) Then
ThreeParameterVlookup = CVErr(xlErrRef)
End If
If (Col <= No_of_Cols_in_Range) Then
Do
If ((Data_Range.Cells(Current_Row, 1).Value = Parameter1) And _
(Data_Range.Cells(Current_Row, 2).Value = Parameter2) And _
(Data_Range.Cells(Current_Row, 3).Value = Parameter3)) Then
Matching_Row = Current_Row

End If
Current_Row = Current_Row + 1
Loop Until ((Current_Row = No_Of_Rows_in_Range) Or (Matching_Row <> 0))

If Matching_Row <> 0 Then
ThreeParameterVlookup = Data_Range.Cells(Matching_Row, Col)
End If

End If

End Function

It has the following syntax:

ThreeParameterVlookup(Data_Range, Col , Parameter1, Parameter2 , Parameter3 )

Where:
• Data_Range is the range of the data
• Col is an integer for the required column
• Parameter1, Parameter2 and Parameter3 are the values from the first three columns respectively

So that:

=ThreeParameterVlookup(B6:G12,6,”Mark”,”Brown”,7) will return ”Tolworth” as this is a match on “Mark”, “Brown”, and 7 and a reference to the 6th column

Note that this function will also worked with (dynamic) named ranges as well:

=ThreeParameterVlookup(named_range,6,”Adrian”,”White”,7) will return “Chessington” where we have set up the named range “Named_Range”.

If Excel can’t locate a match then “N/A” is returned by default. In fact, the function assumes a value of N/A at the outset and then only changes when it finds an exact match.

Also if the value of Col exceeds the number of columns then a Reference error occurs.

To download the .XLSM file for this tutorial, click here

The standard dynamic range uses a named range based on the COUNTA formulae:

=OFFSET($H$1,0,0,COUNT($H:$H),1)

However, this only works where there are no blanks in the data. If the data is purely numeric, and contains blank cells in the data then use a range such as:

=OFFSET($H$1,0,0,MATCH(1E+306,$H:$H,1),1)

If the data is purely text then we will need a named range such as:

=OFFSET($H$1,0,0,MATCH(”*”,$H:$H,-1),1)

And if we have a mixture of text, numbers and spaces:

=OFFSET(Sheet1!$H$1,0,0,MAX(MATCH(1E+306,Sheet1!$A:$A,1), MATCH(”*”,Sheet1!$H:$H,-1)),1)

Where we take the maximum of the two previous match functions.
If we need a range that expands for every day of this calendar year:

=OFFSET(Sheet1!$A$1,0,0,1+TODAY()-DATE(YEAR(TODAY()),1,1),1)