My Excel and VBA Blog

Excel Training Handout

2007-10-23T09:03:00.000-04:00

Recently, I conducted a training session for Ohio Association for Institutional Research and Planning (OAIRP). Here are the files that I used for the training:

handout.pdf

Excercise.xls

Formulae.xls

Convert Text to Uppercase

2007-09-17T09:21:00.000-04:00

If you want to convert the text to uppercase, use the following code; however, I recommend downloading ASAP Utilities, it has many functionalities, including text conversion. It doesn't offer source code though.

Here's my code for uppercase conversion:
(If you want to convert your text to lowercase, replace Ucase with Lcase function in the code)

'Will convert selected range to Upper case, using array
Sub Conv2UCase()
On Error GoTo Conv2UCase_Error

Dim vDataArr As Variant
Dim lUpperBndRow As Long, lUpperBndCol As Long
Dim lRow As Long, lCol As Long

'store selected values in an array
vDataArr = Selection
'get the upper bound of rows
lUpperBndRow = UBound(vDataArr, 1)
'get the upper bound of cols
lUpperBndCol = UBound(vDataArr, 2)

'Start a loop to go through all the elements of the array
For lRow = 1 To lUpperBndRow
    For lCol = 1 To lUpperBndCol
        'Check if the value is text, if not don't convert
        If WorksheetFunction.IsText(vDataArr(lRow, lCol)) Then
            'Convert values to upper case
            vDataArr(lRow, lCol) = UCase(vDataArr(lRow, lCol))
        End If
    Next lCol
Next lRow
'Return the converted values to the range
Selection = vDataArr
Exit Sub

Conv2UCase_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Sub:Conv2UCase"
End Sub

Excel Books

2007-09-06T08:56:00.000-04:00

Books on my shelf:
Professional Excel Development by Stephen Bullen, Rob Bovey This is by far the most authoritative book on Excel development from Add-ins to APIs. A word of caution though, it is not for the beginners.
Excel Advanced Report Development by Timothy Zapawa Ever wondered on using Excel as a report development tool? This might be an answer to it; however, my problem with this book is that it focuses too much on pivottables, and because of that it doesn’t do justification to the name of the book. At any rate, this is very good book to exploit pivottable to its limits.
Excel 2007 Power Programming with VBA by John Walkenbach Of course, it cannot happen that you talk about Excel books and don’t mention Mr. Spreadsheet himself. I am his fan on personal and professional level. On personal level, I love his blog, and on professional level, I like his lucid language in his books. I recommend reading his books and blog both.
Excel 2003 Formulas by John Walkenbach You thought you knew formulas? Just read this book and you’ll realize, which I do almost every day, that there just so much about Excel that we don’t know. John uses simple language, and introduces the readers from basic to advanced formulas. How advance you might ask, well, here is an example, which uses a formula similar to this:
Excel 2007 Formulas by John Walkenbach
Books that I have Read:
Data Analysis and Decision Making with Microsoft Excel by S. Christian Albright I borrowed this book from the library. It is a very good for beginners.
Excel 2003 Power Programming with VBA by John Walkenbach
Integrating Excel and Access by Michael Schmalz I borrowed this book from the library too. Excellent reference on developing applications using Access, Excel, and VBA.
Mr Excel ON EXCEL by Bill Jelen Probably, this is my first book, which I read on Excel by Bill Jelen aka Mr. Excel. Fantastic book. If you have started knowing Excel just now, obtain a copy of this book right away. This is the right start for beginners. It uses very simple and clear language, and Bill provides great examples to make the learning useful.
Guerilla Data Analysis Using Microsoft Excel by Bill Jelen I had an e-version of this book, but for some reason its not working anymore. Anyway, I had chewed this book a lot. Again, it’s a great book for starters, especially, in data crunching.

A function to reverse a string

2007-08-16T10:19:00.000-04:00

Very simple, uses the VBA function StrReverse to reverse the input string.

'A function to reverse a string provided as input
'For example, the string "abcd" will become "dcba"
'Uses the VBA function StrReverse
Public Function ReverseString(sInputString As String) As String
On Error GoTo ReverseString_Error

ReverseString = StrReverse(sInputString)
    Exit Function

ReverseString_Error:
    ReverseString = "#ERROR#"
End Function

Concatenate function

2007-07-24T12:24:00.000-04:00

Oh, man, I can't tell how useful that concatenate function is.

One repetitive use I found is to create OR/AND conditions for Access queries. I copy-paste the field values of a column from Access, do some filtering and my conditions are ready. Then I use this concatfunc to create a string to use in my Access query.

For example, look at this print screen:

The Range A1:A4 houses the string condition I want to use in my Access query to restrict the fruits from my data. In cell B1 I have the formula

=PERSONAL.XLS!concatfunc(A1:A4,CHAR(34) & " or " & CHAR(34))

, and the return string from this function is listed in cell B1.

Now, all you have to do is copy and paste this in Access criteria and put a quotation mark at the start and at the end of this string.

I have found one more use of this when I want to store some values in an Array, using the Array function in VBA.

One more print screen:

In this example, I insert a comma (CHAR(44) instead of string OR, and this function returns a string that I can use in VBA to store these values in an array using Array function, after adding a quotation mark, of course, at the start and at the end.

Print Structures of dbf files in separate workbooks

2007-07-24T11:48:00.000-04:00

Recently, I had the need of printing the data structures of many dbf files. A google search reveled the DBF.COM file that would output dbf file structures, number of records, file name, date of last update, etc.

Download this file here: files/DBF.COM (Caution: I downloaded this file from the internet, and I do not make any warranty of it being spyware or malicious ware free. Use it on your own risk.)

To use this file go to Start>Run>cmd and in DOS type:

cd C:/

dbf.com > myfilestru.txt

Note: cd is used to change the current directory

Here's a print screen:

This will create a file myfilestru.txt in the same directory where your dbf files are residing. This text file will look like this:

Now, that we have a text file all the file structures, we need to create separate workbooks for each dbf file. To do that open this text file in Excel, press Alt + F11 to view the VBA window, double-click the sheet name, and paste this code. After that run this code, and you should have separate workbooks for each dbf file.

Sub FormatThisFile()
'Define some variables
Dim iLastRow As Integer, i As Integer, sWrkbkNm As String, sNewWrkbkNm As String
Dim iPrevLastRow As Integer, iFirstRow As Integer, iNewWrkbkRow As Integer

On Error GoTo FormatThisFile_Error
'Turn off the screen update to run the macro faster
Application.ScreenUpdating = False

'Refer to the current workbook and sheet1
With ThisWorkbook.Sheets(1)
    'get the last row number
    iLastRow = .Range("A65536").End(xlUp).Row
    i = 1
    Do While i < iLastRow
        'search for string "Structure for"
        If InStr(1, .Range("A" & i), "Structure for") > 0 Then
            'if found then store the file name
            sWrkbkNm = Trim(Right(.Range("A" & i), Len(.Range("A" & i)) - Application.WorksheetFunction.Find(":", .Range("A" & i))))
            sWrkbkNm = Left(sWrkbkNm, Len(sWrkbkNm) - 4)
            iFirstRow = i
        'search for string "** Total **"
        ElseIf InStr(1, .Range("A" & i), "** Total **") > 0 Then
            iPrevLastRow = i
            'add a workbook
            Workbooks.Add
            'save it
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & sWrkbkNm
            sNewWrkbkNm = sWrkbkNm & ".xls"
            'with this new workbook do copy-paste
            With Workbooks(sNewWrkbkNm)
                ThisWorkbook.Sheets(1).Range("A" & iFirstRow & ":" & "A" & iPrevLastRow).Copy Destination:= _
                .Sheets(1).Range("A1")
                iNewWrkbkRow = .Sheets(1).Range("A65536").End(xlUp).Row
                .Sheets(1).Range("A4:A" & iNewWrkbkRow).TextToColumns Destination:= _
                .Sheets(1).Range("A4"), DataType:=xlDelimited, Space:=True
                .Sheets(1).Range("A5:A" & iNewWrkbkRow - 1).Delete Shift:=xlToLeft
                .Sheets(1).Columns("A:IV").EntireColumn.AutoFit
                .Sheets(1).Columns("A:IV").WrapText = False
                'save and close this workbook
                .Save
                .Close
            End With
        End If
        i = i + 1
    Loop
    MsgBox "Done"
End With

On Error GoTo 0
SmoothExit_FormatThisFile:
    Application.ScreenUpdating = True
    Exit Sub

FormatThisFile_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure FormatThisFile"
    Resume SmoothExit_FormatThisFile

End Sub

Access VBA: Convert Access tables to arff format

2007-07-18T16:37:00.001-04:00

Weka, an open source data mining software, uses arff input data format. You can use this code to convert any Access table to arff format. Download the Access database with code: Convert2Arff.mdb

This can very well be designed using forms, but this should get one started. Use Alt + F11 to see the code, then execute procedure ConvertTbl2Arff to convert a table.

Some highlights of this procedure
- Takes care of spaces in Attribute name and data values
- Finds unique values of nominal variables
- Assigns equivalent ARFF datatype
- Replaces missing values with question marks

Access VBA: Export Access tables using ODBC

2007-07-18T16:28:00.000-04:00

If you want to export Access tables using ODBC/DSN connections, use the following code. This procedure uses the File DSN and ODBC connection to export Access tables using DAO object TableDef.

Sub ExportTbls()

Dim sTblNm As String
Dim sTypExprt As String
Dim sCnxnStr  As String, vStTime As Variant
Dim db As Database, tbldef As DAO.TableDef

On Error GoTo ExportTbls_Error

sTypExprt = "ODBC Database" 'Export Type
sCnxnStr = "ODBC;DSN=DSNName;UID=userID;PWD=password" 'Create the connection string

vStTime = Timer
Application.Echo False, "Visual Basic code is executing."

Set db = CurrentDb()

'need a reference to Microsoft DAO 3.x library
For Each tbldef In db.TableDefs
    'Don't export System and temporary tables
    If Left(tbldef.Name, 4) <> "MSys" And Left(tbldef.Name, 4) <> "~TMP" Then
          'Debug.Print tbldef.Name
          sTblNm = tbldef.Name
          DoCmd.TransferDatabase acExport, sTypExprt, sCnxnStr, acTable, sTblNm, sTblNm
    End If
Next tbldef

MsgBox "Done! Time taken=" & Timer - vStTime

On Error GoTo 0
SmoothExit_ExportTbls:
    Set db = Nothing
    Application.Echo True
    Exit Sub

ExportTbls_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ExportTblsODST"
    Resume SmoothExit_ExportTbls
End Sub

Access VBA: Delete tables from Access database

2007-07-18T16:21:00.000-04:00

If you want to delete all or some of the tables from your Access database, you can use this DAO approach. You would need a reference to Microsoft DAO 3.x object library. As shown in the example, you can use an array to store the table names, which you want to keep or delete.

Sub DelteTbls()
Dim sTblNm As String
Dim db As Database, tbldef As DAO.TableDef
Dim i As Integer, Arr As Variant

On Error GoTo DelteTbls_Error
'You can use an array if you want to delete or not delete specific tables
'Arr = Array("Table1","Table2","Table3")

Set db = CurrentDb() 'Set the database object

'Set the warnings off to suppress messages
DoCmd.SetWarnings False

'For i = 0 To UBound(Arr)
    For Each tbldef In db.TableDefs
        'here you can use equal to or not equal to delete or keep specific tables
        'If Left(tbldef.Name, 4) = Arr(i) Then
        'Don't delete System or temporary tables
        If Left(tbldef.Name, 4) <> "MSys" And Left(tbldef.Name, 1) <> "~" Then
              Debug.Print tbldef.Name
              sTblNm = tbldef.Name
              'Delete table
              DoCmd.DeleteObject acTable, sTblNm
        End If
    Next tbldef
'Next i

MsgBox "Done!"

On Error GoTo 0

SmoothExit_DelteTbls:
    Set db = Nothing
    DoCmd.SetWarnings True
    Exit Sub

DelteTbls_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure DelteTbls"
    Resume SmoothExit_DelteTbls
End Sub

Access VBA: Link all Dbase files from a folder

2007-07-18T16:19:00.001-04:00

If you would like to link all Dbase files, any linkable file for that matter, in MS Access, use the following code. I read somewhere that refreshing the links is slower than deleting and creating new links.

Sub LinkAllTblsinDir()
Dim sTblNm As String, sPath As String, sFileNm As String
sPath = "C:\DW\"
'Turn of the Echo to avoid window repaint/refresh
Application.Echo False

sFileNm = Dir(sPath, vbNormal)
Do While sFileNm <> ""
    If Right(sFileNm, 3) = "dbf" Then
        sTblNm = Left(sFileNm, Len(sFileNm) - 4) 'Extract the file name
        'Use the TransferDatabase option to link the tables from the specified directory
        'to your current Access DB
        DoCmd.TransferDatabase acLink, "dBase III", sPath, acTable, sTblNm, sTblNm
    End If
    sFileNm = Dir
Loop

Application.Echo True
End Sub

Get file names from a directory

2007-07-18T16:08:00.000-04:00

If you want get or print file names from a certain directory, then you can use following code.

Sub GetFileNames()
Dim sPath As String, sFileNm As String

sPath = "C:\DW\"
'You can also use Application.GetOpenFilename to get a file name from a folder,
'and then extract the Directory name from that string
'You can also use filters with GetOpenFilenam such as *.txt, see Help on this topic

sFileNm = Dir(sPath, vbNormal) 'Get the first file from the specified directory
'Start a loop
Do While sFileNm <> ""
    'If the file has a dbf extension then print the file name
    If Right(sFileNm, 3) = "dbf" Then
         Debug.Print sFileNm
    End If
    sFileNm = Dir
Loop
End Sub

Range Concatenation with a character

2007-06-29T10:03:00.000-04:00

Are you frustrated because you have to concatenate a range, and you have to do that using CONCATENATE formula by entering each cell and putting a comma after every cell? Well, here's a solution to it. A procedure or a function whatever you like. If you use the procedure, it allows you to choose the input range, concatenate character, and the output range. If you use the function, then you can enter the optional concatenate character (by default it is a comma (,)), and the input range.

Here are both:

Procedure:

Public Sub ConCatwChar()
Dim sChar2bAdded As String, rngRng2bCated As Range, sOutput As String, rngTarget As Range, c As Range
On Error GoTo ConCatwChar_Error
'You could use this line to return the concatenated string in this cell
'Set rngTarget = ActiveCell

Set rngRng2bCated = Application.InputBox(prompt:="Select the range you'd like to concatenate with a charcter", _
                    Title:="Select Range", Type:=8)

If rngRng2bCated Is Nothing Then Exit Sub

'You could use this line to set the default to a comma and remove the inputbox line
'sChar2bAdded = ","
sChar2bAdded = InputBox("Enter the character you'd like to add between other cells", "Enter Character", ",")

Set rngTarget = Application.InputBox(prompt:="Select the range you'd like the output", _
                    Title:="Select Range", Type:=8)

For Each c In rngRng2bCated
    sOutput = sOutput & c.Value & sChar2bAdded
Next c

sOutput = Left(sOutput, Len(sOutput) - Len(sChar2bAdded))
rngTarget = sOutput

On Error GoTo 0
   Exit Sub

ConCatwChar_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ConCatwChar"
End Sub

Here's the function:

'You can change the option string character to nothing "" so that you get concatenated string without a character in between
Public Function ConCatFunc(rngRng2bCated As Range, Optional sChar2bAdded As String = ",") As String
Dim sOutput As String, c As Range

On Error GoTo ConCatFunc_Error

For Each c In rngRng2bCated
    sOutput = sOutput & c.Value & sChar2bAdded
Next c
sOutput = Left(sOutput, Len(sOutput) - Len(sChar2bAdded))
ConCatFunc = sOutput

On Error GoTo 0
   Exit Function

ConCatFunc_Error:
    ConCatFunc = "#Error#"

End Function

Here's an example:

Text Search Count

2007-06-29T09:40:00.000-04:00

If you want to do a text search count in a range, you can use the following formulas:
Where D3 is the search text and the range A2:A16 houses the data.

An array formula using SUM and SEARCH

{=SUM(IF(ISERROR(SEARCH(D3,A2:A16)),0,1))}

Another using COUNTIF:

=COUNTIF(A2:A16,"*"&D3&"*")

This picture might make it clear:

Change Row and Column Headers

2006-08-17T13:57:00.000-04:00

You cannot change the default Row (1,2,3,...) and Column (A,B,C,D....) headers, but a workaround is:
1. Enter what you'd like to be your Row Headers in the first column after cell A1
2. Enter what you'd like to be your Column Headers in the first row after cell A1
3. Format first row and column to match the default headers
4. Go to Tools>Options>View Tab>Clear the Row & column Headers check box.

Now, your sheet might look like this:

Assign macro to a button

2006-08-11T12:41:00.000-04:00

In this short video you can learn how to assign a macro to a button on your toolbar. If this macro is in the personal workbook then you can use it on any workbook.

Count cells without formulae

2006-08-07T11:41:00.000-04:00

If you want to count cells in a given range without formulae use this function

Function CountNoFormula(rng As Range) As Long
Dim c As Range
   On Error GoTo CountNoFormula_Error
    For Each c In rng
        If Not c.HasFormula Then
            CountNoFormula = CountNoFormula + 1
        End If
    Next c
CountNoFormula_CleanUpExit:
   Exit Function
CountNoFormula_Error:
    CountNoFormula = CVErr(Err.Number)
    Resume CountNoFormula_CleanUpExit
End Function

If you want to count cells with formule then just remove then "Not" in front of c.HasFormula

Average of n samllest or n biggest numbers from a list

2006-02-22T12:58:00.000-05:00

To calculate the average of n biggest numbers from a list enter this formula with Ctrl + Shift + Enter:

=AVERAGE(IF(RANK(yourrange,yourrange)<=n,yourrange,""))

To calculate the average of n smallest numbers from a list enter this formula with Ctrl + Shift + Enter:

=AVERAGE(IF(RANK(yourrange,yourrange)>COUNT(yourrange)-n,yourrange,""))

For an example:

Add Specific number of zeros to a value

2006-02-08T14:47:00.000-05:00

This is one of the finest forumlae I've ever seen. Check this post at MrExcel.

If you want to have a value specific number of digits otherwise add zeros in front of it, this formula could be used:
=TEXT(A1,REPT("0",n))
where n is the number of digits you want.

So 4555 becomes 000004555 with formula =TEXT(4555,REPT("0",9))

MOD Function and Mod Operator Return Different Values

2006-02-08T11:22:00.000-05:00

I didn't know this before today when an user at MrExcel wondered why he was not getting consistent answers with Excel and VBA. The key is negative numbers.

If you happen to have negative numbers (one of them) and you want to calculate MOD, you should use this code in VBA

yourmodval=n-d*INT(n/d)

Where n is your number and d is your divisor.

For more info, check:
MOD Function and Mod Operator Return Different Values

Change references

2006-02-01T14:00:00.000-05:00

If you want to change references of a formula, you could toggle F4 key inside the formula to change the references from Absolute, Column Absolute Row Absolute or all relative.

Although, if you have to change references from a range, you can use these two options
1. Download ASAP utilities, because it's worth it, they have more than 300 utilities which are used many times.

2. Use this code.

Sub Change_refs()
'This sub will change references of formula to different options shown by a userform
'This code will not run without the userform
On Error GoTo Change_refs_Error
Load frmRefType
frmRefType.Show
Dim IPFormula As String, OPFormula As String, c As Range
Dim RefStyle As XlReferenceStyle
With frmRefType
    If .obAbs Then
        RefStyle = xlAbsolute
    ElseIf .obCAbs Then
        RefStyle = xlRelRowAbsColumn
    ElseIf .obRAbs Then
        RefStyle = xlAbsRowRelColumn
    ElseIf .obRel Then
        RefStyle = xlRelative
    Else
        Exit Sub
    End If
End With
Application.ScreenUpdating = False
For Each c In Selection
    If IsEmpty(c) Then GoTo Nextc
    IPFormula = c.Formula
    OPFormula = Application.ConvertFormula( _
        Formula:=IPFormula, _
        fromReferenceStyle:=xlA1, _
        toReferenceStyle:=xlA1, ToAbsolute:=RefStyle)
    c.Formula = OPFormula
Nextc:
Next c
Application.ScreenUpdating = True
Unload frmRefType
   On Error GoTo 0
   Exit Sub
Change_refs_Error:
    If Not Application.ScreenUpdating Then Application.ScreenUpdating = True
    Unload frmRefType
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Change_refs"
End Sub

You'll have to download the add-in to make this code run. You can edit the Addin just by opening it in VBA. Here is the Addin. If you install this add in it will create a button "Change References"

Trendline coefficients and regression analysis

2006-01-30T14:54:00.000-05:00

This is a great tutorial by Tushar. It tells you a lot about regression, trendlines and using them in VBA. Check it out!

Trendline coefficients: "Trendline Coefficients and Regression Analysis"

Send File Path-Email via Groupwise

2006-01-30T13:24:00.000-05:00

This is what I had to do lots of times. Send the file path of an Excel workbook to my supervisor. So I created this macro to send the activeworkbook full file path to the specified user. This can actually be well modified to create an AddIn, but for now, this is what is going to be. Insert a module in the personal.xls and insert this code. A reference to "Groupware Type library" is a must to make this macro work.

Option Explicit
Private ogwApp As GroupwareTypeLibrary.Application
Private ogwRootAcct As GroupwareTypeLibrary.Account
Sub SendEmail()

Dim strRecipient As String
On Error GoTo SendEmail_Error
strRecipient = InputBox("Enter the email address of recepient", "Recipient Name")
If strRecipient = "" Then
    MsgBox "No Recipient specified", vbCritical
    Exit Sub
End If
Const NGW$ = "NGW"
Dim ogwNewMessage As GroupwareTypeLibrary.Mail
Dim StrSubject As String, StrBody As String
Dim strWkbkName As String, strWkbkPath As String
strWkbkName = ActiveWorkbook.Name
StrSubject = strWkbkName & "-File"
strWkbkPath = ActiveWorkbook.Path
StrBody = "Please find the file-" & strWkbkName & " here- " & strWkbkPath & "\" & strWkbkName
StrBody = StrBody & vbCrLf & vbCrLf & "Thanks"
If ogwApp Is Nothing Then 'Need to set object reference
        DoEvents
        Set ogwApp = CreateObject("NovellGroupWareSession")
        DoEvents
End If
Dim StrLoginName As String, StrMailPassword As String
Set ogwRootAcct = ogwApp.Login
Set ogwNewMessage = ogwRootAcct.WorkFolder.Messages.Add("GW.MESSAGE.MAIL", egwDraft)
DoEvents
With ogwNewMessage
        .Recipients.Add (strRecipient)
         'Assign the SUBJECT text
        .Subject = StrSubject
         'Assign the BODY text
         .BodyText = StrBody
         'Send the message
        .Send
        DoEvents
End With
   On Error GoTo 0
   Set ogwRootAcct = Nothing
   Set ogwNewMessage = Nothing
   Set ogwApp = Nothing
   Exit Sub
SendEmail_Error:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure SendEmail"
    Set ogwRootAcct = Nothing
   Set ogwNewMessage = Nothing
   Set ogwApp = Nothing
End Sub

'http://www.phhp.ufl.edu/~smanamal/misc/Groupwise.htm
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=277

Auto increment a cell

2006-01-27T12:18:00.000-05:00

Suppose if you want to increment a cell by 1 to see how your formulae handle that change, may be a simulation. That means that cell would be incremented by 1 everytime you hit F9 (keyboard short cut to make Excel recalculate). To achieve this do the following:

1. On the Tools menu, click Options, and then click the Calculation tab.
2. Select the Iteration check box.
3. Set the maximum number of times Microsoft Excel will recalculate, type one as the number of iterations in the Maximum iterations box

-MS Excel Help

Then enter this formula in the cell which you want to increment, suppose it's A1.
Formula for A1: =A1+1.

That's it! Now, every time you hit F9, that cell will be incremented by 1. If you want it increment by some other number, use that number in the formula.

List of resources that are available to help you learn Visual Basic for Applications programming

2006-01-23T11:35:00.000-05:00

Check this article @ MS's website to know where to get help for VBA programming.

List of resources that are available to help you learn Visual Basic for Applications programming

Random Numbers

2006-01-21T12:59:00.000-05:00

Recently, I had the need of generating different types of random numbers. Although, Excel's Data Analysis Toolpak can generate good random numbers, I had to create these functions to meet my needs.

First: Unique Random Numbers
This function was modified from ozgrid's RandLotto function, which returns string. This function will return an array of unqiue random integers in the given range. If you want to return more than one number then this function should be entered as an array formula with Ctrl + Shift + Enter.

Function UniqueRand(lngSmallest As Long, lngHighest As Long, HowManyNos As Long) As Long()
'modified from http://www.ozgrid.com/VBA/RandomNumbers.htm
    Dim iArr As Variant
    Dim i As Integer
    Dim r As Integer
    Dim temp As Integer
    Application.Volatile
    ReDim iArr(lngSmallest To lngHighest)
    For i = lngSmallest To lngHighest
        iArr(i) = i
    Next i
    For i = lngHighest To lngSmallest + 1 Step -1
        r = Int(Rnd() * (i - lngSmallest + 1)) + lngSmallest
        temp = iArr(r)
        iArr(r) = iArr(i)
        iArr(i) = temp
    Next i
    Dim resultArr() As Long: ReDim resultArr(HowManyNos - 1, 0)
    For i = lngSmallest To lngSmallest + HowManyNos - 1
        resultArr(j, 0) = iArr(i)
        j = j + 1
    Next i
    UniqueRand = resultArr
End Function

Second: Gaussian or Normal Random Numbers with specified mean and Standard deviation(SD). Now, this function is different than the Analysis toolpak utility because it generates random numbers on a fixed mean and Standard deviation. This function will allow the user to generate random numbers each with different mean and SD.

'This function will generate Gaussian or Normal Random Numbers based on given mean and SD
Public Function GenGaussNoise(mean As Double, SD As Double, HowMany As Long) As Double()
Dim x As Double, i As Long, j As Long
itr = 50
Dim dblResArr() As Double: ReDim dblResArr(HowMany - 1, 0)
For j = 1 To HowMany
    x = 0
    For i = 1 To itr
        Randomize
        U = Rnd
        x = x + U
    Next i
    ' /* for uniform randoms in [0,1], mu = 0.5 and var = 1/12 */
    ' /* adjust X so mu = 0 and var = 1 */
    x = x - itr / 2             ' /* set mean to 0 */
    x = x * Sqr(12 / itr)     '  /* adjust variance to 1 */
    dblResArr(j - 1, 0) = mean + SD * x
Next j
    GenGaussNoise = dblResArr
End Function

Third: Generate white noise or Guassian or Normal random numbers with mean = 0 and SD =1. Although, this could be achieved by the previous function, this function uses Box-Muller method. In this function too, you can use different mean and SD, although if not provided it would take mean =0 and SD=1

Public Function GenWhiteNoise(HowMany As Long, Optional mean As Double = 0, Optional variance As Double = 1) As Double()
'Returns a normally distributed random variate with mean 0 and variance 1, a.k.a. "White Noise".
'  Uses the Box-Muller method
    Dim Value1 As Single, Value2 As Single, Fac As Single, Rsq As Single, SD As Double
    Dim dblResArr() As Double: ReDim dblResArr(HowMany - 1, 0)
    SD = Sqr(variance)
    For i = 1 To HowMany
        Do
            Randomize
            Value1 = 2 * Rnd - 1
            Value2 = 2 * Rnd - 1
            Rsq = Value1 ^ 2 + Value2 ^ 2
        Loop Until Rsq > 0 And Rsq < 1
        Fac = (-2 * Log(Rsq) / Rsq) ^ 0.5
        If Rnd < 0.5 Then
            dblResArr(i - 1, 0) = mean + SD * Value1 * Fac
        Else
            dblResArr(i - 1, 0) = mean + SD * Value2 * Fac
        End If
    Next i
    GenWhiteNoise = dblResArr
End Function

This is a screenshot of the Excel file. Also, the original Excel file can be downloaded here.