DandelionFinal2

Dandelions are weeds. I’ve spent more hours weeding them out of my family’s yard and my grandparents’ yards than I care to count. Yet, when you come across them in a meadow, they are very nice to look at and add a kind of tranquility in their own right. They are edible and make a nice tasting wine. Here’s a recipe from AllRecipes. Let us know how it turns out.

Today’s post, however, is not about dandelions or wine making – it about the Filter Property of ADO Recordsets.


    edit: As is my usual practice, I am going to use Late Binding in the sample snippets below. A discussion on Late / Early Binding is beyond the scope of this post. Please see these links for a detailed explanation of Late / Early Binding.

    1. Beyond Excel
    2. JP Software Technologies


In my last post on ADO Recordsets, I demonstrated some VBA to load a Worksheet Range into a Recordset – check it out here.

First Step

Before I filter the Recordset, I would like to manually filter the dataset so I can determine what the final results should be so I can compare to make sure everything goes correctly with the Recordset Filter.

RecordsAllFinal

Here’s some data I borrowed from Marco Russo and Alberto Ferrari. It looks as though it may have come from the AdventureWorks Database. There are a total of 60,398 records.

Now I’ll filter on the SalesManager field to look at records that are not related to Marco.

RecordsFilteredFinal

OK, 25,109 records remain after I filter out records for Marco so When I filter the Recordset, I should receive 25,109 records. I removed the AutoFilter, now I am ready to Filter the Recordset

Global Constants

In my last post. on ADO Recordsets, I began by adding some Global Constants to a module named “M_Globals”. I’m going to add a few new constants for the Filter Group Enumeration. I may use them, I may not. But at least I have them defined if I do need them.

'Filter Group Enumeration
    Public Const gcladFilterNone = 0                 'No filter. This value removes the current filter and restores all records to view.
    Public Const gcladFilterPendingRecords = 1       'Use the pending records. This value allows viewing only those records that have changed but have not yet been sent to the server. This value is only applicable for batch update mode.
    Public Const gcladFilterAffectedRecords = 2      'Use only records affected by the last Delete, Resync, UpdateBatch, or CancelBatch call.
    Public Const gcladFilterFetchedRecords = 3       'Use the last fetched records. This value allows viewing the records in the current cache returned as a result of the last call to retrieve records (implying a resynchronization).
    Public Const gcladFilterConflictingRecords = 5   'Use the conflicting records. This value allows viewing only those records that failed the last batch update.

Load The Recordset

I won’t clutter this tutorial by reposting the same code I posted in my last article on ADO Recordsets, check the Sub() out here.

Filter The Recordset

Now that I have a Recordset, I just need to add a bit of code to filter it. Recall, I am interested in all records where the Sales Manager is not Marco. So my criteria string will be something like “SalesManager <> ‘Marco Russo'”

I just need to add 6 lines to my original Sub() and of those, 2 lines are comment lines (I could use fewer lines, I’m using additional lines for clarity)

        Dim strFilter As String
        'Filter string
            strFilter = "SalesManager <> 'Marco Russo'"
        'Filter the Recordset and display the filter record and field count to check results
            rs.Filter = strFilter
            Debug.Print "The filtered recordset contains " & Format(rs.RecordCount, "##,##0") & " records and " & rs.Fields.Count & " fields"

Returns:

The original recordset contains 60,398 records and 23 fields
The filtered recordset contains 25,109 records and 23 fields

Perfect! The Filtered Recordset matches with the results I obtained earlier by manually filtering the Range.

Gimmee The Data…

Most likely, we want to return the dataset back to the user in either a new workbook or a new worksheet. For today, I’ll return the Filtered Recordset back to the same Workbook on a new Worksheet.

Add A Worksheet

I’ll create a Function to add a worksheet to a workbook so that I have a safe place to return the results of the Filtered Recordset

Public Function AddWorksheet(wb As Workbook) As Worksheet

    'Declare variables
        Dim wsNew As Worksheet
        
    'Add worksheet to end of other worksheets in the workbook
        With wb
            Set wsNew = .Worksheets.Add _
                                    (After:=.Worksheets(.Worksheets.Count))
                            
        End With
        
    'Return object to function
        Set AddWorksheet = wsNew
        
    'Tidy up
        Set wsNew = Nothing
        
End Function

And I call the Function here:

        'Add a worksheet for the filtered results
            Set wsResults = AddWorksheet(wb:=wb)

CopyFromRecordset Method

The Range Object has a CopyFromRecordset Method, so I’ll use that:

        'Copy the filtered recordset to the results range
        'The CopyFromRecordset Method does not include headers
            wsResults.Cells(1, 1).CopyFromRecordset rs

And the output:
RecordsetOutFinal

It’s looking good. The record count matches with what I expected from the manual filter process at the top of the post. The only problem is that the CopyFromRecordset Method does not include the field headers, so I’ll need a small Sub() to get the field headers and then output the Recordset to Cell(2,1) instead of Cell(1,1).

The Fields Collection

The Recordset Object has a Fields Collection, so I can loop through the Fields Collection to get the Field Names. The gotcha here is that the Fields Collection begins as zero – so be aware of that.

Here’s the Sub():

Public Sub GetRSFieldNames(ws As Worksheet, _
                           rs As Object)
                           
    'Declare variables
        Dim x As Long
        
    'Get field names
        For x = 0 To rs.Fields.Count - 1
            ws.Cells(1, x + 1).Value = rs.Fields(x).Name
        Next x
    
End Sub

Here is how I called the Sub():

        'Output Recordset Field Names to the worksheet
            Call GetRSFieldNames(ws:=wsResults, _
                                 rs:=rs)

And the Output:
RecordWFieldsFinal

Looks pretty good – I just want to add some formatting to improve readability.

CharlieDanielsFinal

Fiddle Factor

No – not Charlie Daniels pictured here sawing on a fiddle and playing it hot as in The Devil Went Down To Georgia. Rather, Fiddle Factor is a term I learned from one of my supervisors which refers to the amount of time and energy spent formatting an Excel Report. The more time and energy spent – the higher the Fiddle Factor.

But I think formatting is very important. Not only does it make data and information easier to read and understand, but if it is done well, it actually draws or invites the reader in. Stephen Few has quite a bit to say about well-done formatting on his blog, Perceptual Edge.

Enough of my soap box, my goal in this case is not so lofty. I just want to add a bit of color to the header row, fit the column width to the data and maybe play with the zoom level:

Here is the Sub() to format the output:

Sub FormatOutput(ws As Worksheet)

    'Declare variables
        Dim LastColumn As Long
        Dim rngHeader As Range
        Dim lngColor As Long
        
    'initialize
        lngColor = RGB(68, 84, 106)
        
    'Get last column of header row range
        LastColumn = GetLast(ws:=ws, _
                             strType:="c")
                             
    'Create Range Object - header row range
        With ws
            Set rngHeader = .Range(.Cells(1, 1), .Cells(1, LastColumn))
        End With
        
    'Format the header row range
        With rngHeader
            .Interior.Color = lngColor
            .Font.Bold = True
            .Font.Color = vbWhite
        End With
        
    'Format Dates
        With ws
            .Range("L2").EntireColumn.NumberFormat = "MM/DD/YYYY"
        End With
               
    'Set zoom level
        ws.Activate
        ActiveWindow.Zoom = 75
        
    'Fit column width to data
        Columns.AutoFit

End Sub

And here is how I call the Sub():

        'Format the output
            Call FormatOutput(ws:=wsResults)

The Full Monty

Here is the main Sub() with the additions to Filter the Recordset, Output the Recordset to a new Worksheet, and Format the data:

Sub FilterRecordset()

    'Declare variables
        Dim wb As Workbook
        Dim wbADO As Workbook
        Dim ws As Worksheet
        Dim wsResults As Worksheet
        Dim rng As Range
        Dim rngResults As Range
        Dim cn As Object
        Dim rs As Object
        Dim cmd As Object
        Dim strWorksheet As String
        Dim strSQL As String
        Dim strWorkbookADO As String
        Dim strFilter As String
                
    'Excel environemnt
        With Application
            .ScreenUpdating = False
            .DisplayAlerts = False
            .EnableEvents = False
            .Calculation = xlCalculationManual
        End With

    'Initialize
        Set wb = ThisWorkbook
        
        'Get worksheet to be loaded into recordset
            strWorksheet = GetSelectedSheet(strPrompt:="Select a cell on the worksheet to be loaded into the recordset", _
                                            strTitle:="Worksheet To Recordset")
                                            
        'Create a new workbook to hold all data from the selected worksheet
            Set wbADO = Workbooks.Add
            
        'Copy everything from the selected worksheet to the new workbook
            Call CopyData(wbSource:=wb, _
                          wbDestination:=wbADO, _
                          strSource:=strWorksheet)
                          
        'Cleanup the destination workbook
            Call CleanupWorkbook(wb:=wbADO)
            
        'Save and close the data workbook
            With wbADO
                .SaveAs wb.Path & "\" & Mid(wb.Name, 1, Len(wb.Name) - 5) & "_ADO.xlsx", FileFormat:=xlOpenXMLWorkbook
                strWorkbookADO = wbADO.FullName
                .Close
            End With

        'Create a range object to measure source data against final recordset data
            Set ws = wb.Worksheets(strWorksheet)
            Set rng = ws.Range("A1").CurrentRegion

        'SQL string
            strSQL = "SELECT * FROM [Data$]"
            
        'Filter string
            strFilter = "SalesManager <> 'Marco Russo'"

        'Create ADO Connection Object
            Set cn = GetADOConnection()
            cn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;" & _
                     "Data Source=" & strWorkbookADO & ";" & _
                     "Extended Properties='Excel 12.0 Xml;HDR=YES;IMEX=1'")

        'Create ADO Command Object
            Set cmd = GetCommand()
            Set cmd.ActiveConnection = cn
            cmd.CommandType = gcladCmdText
            cmd.CommandText = strSQL                        'Pass SQL String to the command object

        'Create ADO Recordset Object and load records
            Set rs = GetRecordset()
            With rs
                .CursorLocation = gcladUseClient
                .CursorType = gcladOpenDynamic
                .LockType = gcladLockOptimistic
                .Open cmd
            End With

        'Compare recordset results to original data
            Debug.Print "The original recordset contains " & Format(rs.RecordCount, "##,##0") & " records and " & rs.Fields.Count & " fields"
            Debug.Print "The range contains " & Format(rng.Rows.Count - 1, "##,##0") & " rows and " & rng.Columns.Count & " columns" '-1 to discount header row
            
        'Filter the Recordset
            rs.Filter = strFilter
            
        'Add a worksheet for the filtered results
            Set wsResults = AddWorksheet(wb:=wb)
            
        'Output Recordset Field Names to the worksheet
            Call GetRSFieldNames(ws:=wsResults, _
                                 rs:=rs)
            
        'Copy the filtered recordset to the results range
        'The CopyFromRecordset Method does not include headers
            wsResults.Cells(2, 1).CopyFromRecordset rs
            
        'Format the output
            Call FormatOutput(ws:=wsResults)
    
            
        'Tidy up
            'Close objects
                rs.Close
                cn.Close
                
            'Destroy objects
                Set rs = Nothing
                Set cmd = Nothing
                Set cn = Nothing
                Set rng = Nothing
                Set ws = Nothing
                Set wsResults = Nothing
                Set wbADO = Nothing
                Set wb = Nothing
                
            'Excel environemnt
                With Application
                    .ScreenUpdating = True
                    .DisplayAlerts = True
                    .EnableEvents = True
                    .Calculation = xlCalculationAutomatic
                End With
                    
End Sub

And the final output:

RecordWFieldsAutoFitComplete

Tidy up

Final Thoughts

This post was about Filtering ADO Recordsets. The Filter I used was very simple and only scratches the surface of what is possible. You may use the Filters in combinations with AND, OR, LIKE and Wildcard Characters. Make sure you check out the link to Recordset Filter Property. Lots of great information.

I don’t like that I hard coded the Filter String inside the Sub(). It would be better to offer a user form at run-time to read the fields in the recordset and prompt the user to make choices through Combo Boxes, Check Boxes, etc…

Other Recordset Posts At dataprose.org

Additional Resources

Downloads

Download the file from OneDrive. The filename is Excel – Recordset_v3.xlsm

Credits

Data courtesy Microsoft Excel 2013 Building Data Models with PowerPivot by Alberto Ferrari and Marco Russo (Mar 25, 2013)

FemmesFinal

I hope you know that this will go down on your permanent record
Oh yeah? Well, don’t get so distressed
Did I happen to mention that I’m impressed?

So go the lyrics from Kiss Off by the Violent Femmes pictured here. Great song from the 80’s. If you are not familiar with the Femmes, check ’em out – highly recommended.

However, today’s post is not about the Alternative Rock scene of the early 80’s. Rather, it is about ActiveX Data Objects (ADO) Recordsets.


    edit: As is my usual practice, I am going to use Late Binding in the sample snippets below. A discussion on Late / Early Binding is beyond the scope of this post. Please see these links for a detailed explanation of Late / Early Binding.

    1. Beyond Excel
    2. JP Software Technologies


Global Constants

Because I am using Late Binding, I am going to setup Global Constants for the various Enumerations I need for Command Types, Cursor Locations, Cursor Types and Lock Types. It takes a little bit of extra work, but I think it makes the code clearer:

Clear:

cmd.CommandType = gcladCmdText

Not clear:

cmd.CommandType = 1

See? The Constant is self-documenting and makes the code clearer.

Here’s all the Global Contants. I put them in a Module named “M_Globals” because I’m creative that way.

'Command Type Enumeration Values
    Public Const gcladCmdUnspecified = -1       'Unspecified type of command
    Public Const gcladCmdText = 1               'Evaluates CommandText as a textual definition of a command or stored procedure call
    Public Const gcladCmdTable = 2              'Evaluates CommandText as a table name whose columns are returned by an SQL query
    Public Const gcladCmdStoredProc = 4         'Evaluates CommandText as a stored procedure name
    Public Const gcladCmdUnknown = 8            'Default. Unknown type of command
    Public Const gcladCmdFile = 256             'Evaluates CommandText as the file name of a persistently stored Recordset. Used with Recordset.Open or Requery only.
    Public Const gcladCmdTableDirect = 512      'Evaluates CommandText as a table name whose columns are all returned. Used with Recordset.Open or Requery only. To use the Seek method, the Recordset must be opened with adCmdTableDirect. Cannot be combined with the ExecuteOptionEnum value adAsyncExecute.

'Cursor Location Enumeration Values
    Public Const gcladUseNone = 1               'OBSOLETE (appears only for backward compatibility). Does not use cursor services
    Public Const gcladUseServer = 2             'Default. Uses a server-side cursor
    Public Const gcladUseClient = 3             'Uses a client-side cursor supplied by a local cursor library. For backward compatibility, the synonym adUseClientBatch is also supported
    
'Cursor Type Enumeration Values
    Public Const gcladOpenUnspecified = -1      'Unspecified type of cursor
    Public Const gcladOpenForwardOnly = 0       'Default. A forward-only cursor. This improves performance when you need to make only one pass through a Recordset
    Public Const gcladOpenKeyset = 1            'A keyset cursor. Like a dynamic cursor, except that you can't see records that other users add, although records that other users delete are inaccessible from your Recordset. Data changes by other users are still visible.
    Public Const gcladOpenDynamic = 2           'A dynamic cursor. Additions, changes, and deletions by other users are visible, and all types of movement through the Recordset are allowed
    Public Const gcladOpenStatic = 3            'A static cursor. A static copy of a set of records that you can use to find data or generate reports. Additions, changes, or deletions by other users are not visible.

'Lock Type Enumeration Values
    Public Const gcladLockUnspecified = -1      'Unspecified type of lock. Clones inherits lock type from the original Recordset.
    Public Const gcladLockReadOnly = 1          'Default. Read-only records
    Public Const gcladLockPessimistic = 2       'Pessimistic locking, record by record. The provider lock records immediately after editing
    Public Const gcladLockOptimistic = 3        'Optimistic locking, record by record. The provider lock records only when calling update
    Public Const gcladLockBatchOptimistic = 4   'Optimistic batch updates. Required for batch update mode

Let The User Choose Which Worksheet To Load To The Recordset

In the function below, I use an InputBox Type:=8 to let the user choose a cell on the worksheet that contains the data that should be loaded into the recordset:

Public Function GetSelectedSheet(strPrompt As String, _
                                 strTitle As String) As String
     
    'Declare variables
        Dim ws                          As Worksheet
        Dim rng                         As Range
     
    'Users - select a cell on a worksheet
        Set rng = Application.InputBox( _
                                       Prompt:=strPrompt, _
                                       Title:=strTitle, _
                                       Default:=ActiveCell.Address, _
                                       Type:=8) 'Range selection
                     
    'Get the parent worksheet of the selected cell
        Set ws = rng.Parent
         
    'Pass the name of the worksheet to the function
        GetSelectedSheet = ws.Name
     
    'Tidy up
        Set rng = Nothing
        Set ws = Nothing
 End Function

And I call the function like this:

        'Get worksheet to be loaded into recordset
            strWorksheet = GetSelectedSheet(strPrompt:="Select a cell on the worksheet to be loaded into the recordset", _
                                            strTitle:="Worksheet To Recordset")

Save The Data To A New Workbook

I could not get the ADO code to work with data in the same workbook, so in the end I decided to just save the data the user selected out to a new workbook:

First, I added a workbook:

        'Create a new workbook to hold all data from the selected worksheet
            Set wbADO = Workbooks.Add

Then I sent the original workbook, the new workbook and the the worksheet that the user selected to a Private Sub to handle the copying:

Call the sub:

        'Copy everything from the selected worksheet to the new workbook
            Call CopyData(wbSource:=wb, _
                          wbDestination:=wbADO, _
                          strSource:=strWorksheet)

The Sub() to copy the entire worksheet from one workbook to another:

Private Sub CopyData(wbSource As Workbook, _
                     wbDestination As Workbook, _
                     strSource As String)
                     
    wbSource.Worksheets(strSource).Copy wbDestination.Worksheets(1)

End Sub

And then the cleanup:

        'Cleanup the destination workbook
            Call CleanupWorkbook(wb:=wbADO)

The Sub() to handle any cleanup chores:

Private Sub CleanupWorkbook(wb As Workbook)

    'Declare variables
        Dim i As Long
        
    'Rename worksheets
    'Delete unneeded worksheets
        With wb
            .Worksheets(1).Name = "Data"
            For i = .Sheets.Count To 2 Step -1
                .Sheets(i).Delete
            Next i
        End With

End Sub

Lastly, I saved and closed the new workbook, since the ADO Process will want to open the workbook

        'Save and close the data workbook
            With wbADO
                .SaveAs wb.Path & "\" & Mid(wb.Name, 1, Len(wb.Name) - 5) & "_ADO.xlsx", FileFormat:=xlOpenXMLWorkbook
                strWorkbookADO = wbADO.FullName
                .Close
            End With

Create A Range Object To Measure Inputs

I would like to measure the amount of rows and columns in the input Range so that after I load the Recordset I can compare the the Range Dimensions to the Recordset Dimensions.

        'Create a range object to measure source data against final recordset data
            Set ws = wb.Worksheets(strWorksheet)
            Set rng = ws.Range("A1").CurrentRegion

SQL String

I like to create a SQL string and then pass the SQL string to the CommandText Property of the Command Object. I think this makes troubleshooting and tuning the SQL easier:

        'SQL string
            strSQL = "SELECT * FROM [Data$]"

Create The ADO Connection Object

I like to encapsulate any objects I am creating. Here is the function to create the ADO Connection Object:

Public Function GetADOConnection() As Object

    Set GetADOConnection = CreateObject("ADODB.Connection")
  
End Function

And here is how I call it:

        'Create ADO Connection Object
            Set cn = GetADOConnection()

ADO Connection Strings

ADO Connection Strings can be a little challenging, luckily, we have ConnectionStrings.com to help us out. Link is at the bottom of the post. I am using Office 2013 with a workbook in xlOpenXMLWorkbook format (.xlsx). So this is the connection string I’ll be using:

cn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;" & _
         "Data Source=" & strWorkbookADO & ";" & _
         "Extended Properties='Excel 12.0 Xml;HDR=YES;IMEX=1'")

Create The ADO Command Object

Next, I’ll create the ADO Command Object and set some of the properties of the object. Note here that I am using one of the Global Contants that I declared earlier. I also pass my SQL string here:

        'Create ADO Command Object
            Set cmd = GetCommand()
            Set cmd.ActiveConnection = cn
            cmd.CommandType = gcladCmdText
            cmd.CommandText = strSQL                        'Pass SQL String to the command object

And here is the function to create the Command Object :

Public Function GetCommand() As Object

    Set GetCommand = CreateObject("ADODB.Command")
  
End Function

Create And Load The ADO Recordset

Next I need to create and load the recordset.

'Create ADO Recordset Object and load records
            Set rs = GetRecordset()
            With rs
                .CursorLocation = gcladUseClient
                .CursorType = gcladOpenDynamic
                .LockType = gcladLockOptimistic
                .Open cmd
            End With

And here is the encapsulated function that creates the ADO Recordset Object:

Public Function GetRecordset() As Object

    Set GetRecordset = CreateObject("ADODB.Recordset")
  
End Function

Check Recordset Results Against Expected Results

Lastly, I want to compare the Recordset results against expected results. Do do this I will count the number of records and fields in the Recordset and compare them against the number of rows and columns in the Range Object I created earlier:

        'Compare recordset results to original data
            Debug.Print "The recordset contains " & Format(rs.RecordCount, "##,##0") & " records and " & rs.Fields.Count & " fields"
            Debug.Print "The range contains " & Format(rng.Rows.Count - 1, "##,##0") & " rows and " & rng.Columns.Count & " columns" '-1 to discount header row

Returns:

The recordset contains 60,398 records and 23 fields
The range contains 60,398 rows and 23 columns

Everything is working as it should.

The Main Procedure

Sub PopulateRecordset()

    'Declare variables
        Dim wb As Workbook
        Dim wbADO As Workbook
        Dim ws As Worksheet
        Dim rng As Range
        Dim cn As Object
        Dim rs As Object
        Dim cmd As Object
        Dim strWorksheet As String
        Dim strSQL As String
        Dim strWorkbookADO As String
                
    'Excel environemnt
        With Application
            .ScreenUpdating = False
            .DisplayAlerts = False
            .EnableEvents = False
            .Calculation = xlCalculationManual
        End With

    'Initialize
        Set wb = ThisWorkbook
        
        'Get worksheet to be loaded into recordset
            strWorksheet = GetSelectedSheet(strPrompt:="Select a cell on the worksheet to be loaded into the recordset", _
                                            strTitle:="Worksheet To Recordset")
                                            
        'Create a new workbook to hold all data from the selected worksheet
            Set wbADO = Workbooks.Add
            
        'Copy everything from the selected worksheet to the new workbook
            Call CopyData(wbSource:=wb, _
                          wbDestination:=wbADO, _
                          strSource:=strWorksheet)
                          
        'Cleanup the destination workbook
            Call CleanupWorkbook(wb:=wbADO)
            
        'Save and close the data workbook
            With wbADO
                .SaveAs wb.Path & "\" & Mid(wb.Name, 1, Len(wb.Name) - 5) & "_ADO.xlsx", FileFormat:=xlOpenXMLWorkbook
                strWorkbookADO = wbADO.FullName
                .Close
            End With

        'Create a range object to measure source data against final recordset data
            Set ws = wb.Worksheets(strWorksheet)
            Set rng = ws.Range("A1").CurrentRegion

        'SQL string
            strSQL = "SELECT * FROM [Data$]"

        'Create ADO Connection Object
            Set cn = GetADOConnection()
            cn.Open ("Provider=Microsoft.ACE.OLEDB.12.0;" & _
                     "Data Source=" & strWorkbookADO & ";" & _
                     "Extended Properties='Excel 12.0 Xml;HDR=YES;IMEX=1'")

        'Create ADO Command Object
            Set cmd = GetCommand()
            Set cmd.ActiveConnection = cn
            cmd.CommandType = gcladCmdText
            cmd.CommandText = strSQL                        'Pass SQL String to the command object


        'Create ADO Recordset Object and load records
            Set rs = GetRecordset()
            With rs
                .CursorLocation = gcladUseClient
                .CursorType = gcladOpenDynamic
                .LockType = gcladLockOptimistic
                .Open cmd
            End With

        'Compare recordset results to original data
            Debug.Print "The recordset contains " & Format(rs.RecordCount, "##,##0") & " records and " & rs.Fields.Count & " fields"
            Debug.Print "The range contains " & Format(rng.Rows.Count - 1, "##,##0") & " rows and " & rng.Columns.Count & " columns" '-1 to discount header row
            
        'Tidy up
            'Close objects
                rs.Close
                cn.Close
                
            'Destroy objects
                Set rs = Nothing
                Set cmd = Nothing
                Set cn = Nothing
                Set rng = Nothing
                Set ws = Nothing
                Set wbADO = Nothing
                Set wb = Nothing
                
            'Excel environemnt
                With Application
                    .ScreenUpdating = True
                    .DisplayAlerts = True
                    .EnableEvents = True
                    .Calculation = xlCalculationAutomatic
                End With
                    
End Sub

Tidy up

Additional Resources

Downloads

Credits

    Data courtesy Microsoft Excel 2013 Building Data Models with PowerPivot by Alberto Ferrari and Marco Russo (Mar 25, 2013)

Final Thoughts

    I could not get the ADO to work with data in the same workbook that contains the code. That does not mean you cannot – I don’t know. I would generally invoke a FileDialogFilePicker function to select a file that contains the data for processing. That’s it for today. I’ll come back later with more stuff on working with Recordsets. Thanks, Dennis!
, , ,

AdvanceFinal500

AAAAAARRRRGGGGHHHHH!!!!! I just hate reviewing an Excel Workbook with lots of tabs and the ActiveCell is different on every tab. Let’s look at some ways to fix this. Before I can get going, I need to:

  1. Add several copies of a worksheet to the active workbook
  2. Randomize the ActiveCell on each worksheet



    edit: While my main point of this post is the GoTo Method of the Excel Application Object, I touch on many other items as well

  1. Copy Method of the Worksheet Object
  2. Cells Property of the Range Object
  3. Cells Property of the Worksheet Object
  4. Find Method of the Range Object
  5. Range Property of the Worksheet Object
  6. Select..Case Statement
  7. Application Worksheet Function Randbetween
  8. InputBox Method of the Excel Application Object
  9. VBA Instr() Function


Add Worksheet Copies

I downloaded a sample P&L Statement from the Internet. Now I just want to add 29 copies of the P&L Statement to the workbook.

PLStatement

Option Explicit

Sub Foo()

    'Declare variables
        Dim wb As Workbook
        Dim wsPL As Worksheet
    
    'Excel environment
        With Application
            .ScreenUpdating = False
        End With
        
    'Initialize
        Set wb = ThisWorkbook
        Set wsPL = wb.Worksheets("PL_CC")
    
    'Add worksheets
        Call CopyWorksheets(wb:=wb, _
                            wsSource:=wsPL, _
                            NumberOfCopies:=30)

    'Tidy up
        'Destroy objects
            Set wsPL = Nothing
            Set wb = Nothing
            
        'Excel environment
            With Application
                .ScreenUpdating = True
            End With
        
End Sub

Private Sub CopyWorksheets(wb As Workbook, _
                           wsSource As Worksheet, _
                           NumberOfCopies As Long)
    
    'Declare variables
        Dim i As Long
                           
                                   
    'Make copies of worksheet
        For i = 2 To NumberOfCopies
            wsSource.Copy _
                After:=wb.Worksheets(Worksheets.Count)
                ActiveSheet.Name = wsSource.Name & i
        Next i
End Sub

Great! Added 29 copies of the P&L Statement and renamed each worksheet.

PLStatementsMult

Randomize The ActiveCell

Since I made copies of a worksheet the ActiveCell is the same on every worksheet. I want to randomize the ActiveCell before I create some code to set the ActiveCell on every worksheet. The P&L Statement I am using has 15 Columns and 77 Rows. But I would like to determine those values with some VBA so that my code is more dynamic and will wok with any worksheet that I use in the future.

First I’ll check the UsedRange

Private Sub GetUsedRange(ws As Worksheet)

    'Declare variables
        Dim rng As Range
        
    'Create range object
        Set rng = ws.UsedRange
        
    'Print adddress
        Debug.Print rng.Address
        
    'Tidy up
        Set rng = Nothing
  
End Sub

Returns:

$A$1:$Y$77

That’s not what I want. I’m looking for $O$77 as the last used cell.

Last Used Cell Function

This function returns the correct last used cell:

Private Function GetLastUsedCell(ws As Worksheet) As Range

    'Declare variables
        Dim rngLastUsedCell As Range
        
    'Create range object from last used cell
        Set rngLastUsedCell = ActiveSheet.Cells.Find(What:="*", _
                                               After:=ws.Cells(1, 1), _
                                               LookIn:=xlFormulas, _
                                               LookAt:=xlPart, _
                                               SearchOrder:=xlByRows, _
                                               SearchDirection:=xlPrevious, _
                                               MatchCase:=False)

    'Pass object to function
        Set GetLastUsedCell = rngLastUsedCell
    
    'Tidy up
        Set rngLastUsedCell = Nothing
        
End Function

Returns:

$O$77

Perfect! That’s what I was looking for. Now I need to find the first used cell.

First Used Cell Function

In pure violation of the recommendation of Bovey et. al., in their landmark tome, Professional Excel Development: The Definitive Guide to Developing Applications Using Microsoft Excel, VBA, and .NET (2nd Edition), I generally begin all of my worksheets at $A$1, but not always. So I need a function to find the first used cell on the worksheet no matter what worksheet I throw at the function.

Private Function GetFirstUsedCell(ws As Worksheet) As Range

    'Declare variables
        Dim rng As Range
        
    'Create range object from the first cell in the UsedRange
        Set rng = ws.UsedRange.Cells(1, 1)

    'Pass object to function
        Set GetFirstUsedCell = rng
    
    'Tidy up
        Set rng = Nothing
        
End Function

Returns:

$A$1

Excellent! That’s what I was looking for. Now that I have the first and last cells of the true UsedRange, I need to use the first cell and last cell to create a range of everything.

Create A Big Range

Private Function GetBigRange(ws As Worksheet, _
                             rngStart As Range, _
                             rngStop As Range) As Range
                             
    'Declare variables
        Dim rng As Range
        
    'Creat a range object from start and stop range positions
        Set rng = ws.Range(rngStart, rngStop)
        
    'Pass range object to function
        Set GetBigRange = rng
        
    'Tidy up
        Set rng = Nothing
                             
End Function

Returns:

$A$1:$O$77

Awesome! Now, I can use the entire range to generate random values to use for the ActiveCell.

Get Values

I’ll need to call a get value function 4 times to get the first row, the last row, the first column and the last column.

Here’s the function:

Private Function GetValueFromRange(rng As Range, _
                                   strType As String) As Long
    
    'Declare variables
        Dim x As Long
        
    'Get value depending on type
        With rng
            Select Case strType
                Case "FirstRow"
                    x = .Row
                Case "LastRow"
                    x = .Rows.Count
                Case "FirstColumn"
                    x = .Column
                Case "LastColumn"
                    x = .Columns.Count
            End Select
        End With
        
    'Pass value to function
        GetValueFromRange = x
     
End Function

And here is how I called the function 4 different times:

'Get values form total used range
        BeginRow = GetValueFromRange(rng:=rngAll, _
                                     strType:="FirstRow")
                                     
        EndRow = GetValueFromRange(rng:=rngAll, _
                                   strType:="LastRow")
                                   
        BeginColumn = GetValueFromRange(rng:=rngAll, _
                                   strType:="FirstColumn")
                                   
        EndColumn = GetValueFromRange(rng:=rngAll, _
                                   strType:="LastColumn")

Returns:

  • BeginRow 1
  • EndRow 77
  • BeginColumn 1
  • EndColumn 15
  • Gnarly! Now, I have the values that I can pass to a function to generate a random cell reference.

    Get Random Values

    Now that I have high-low pairs for rows and columns, I can use the Worksheet Function Randbetween to generate some random values for the row and column numbers.

    Private Function GetRandomValue(ValueLow As Long, _
                                    ValueHigh As Long) As Long
    
        'Declare variables
            Dim x As Long
            
        'Generate a random value
            x = Application.WorksheetFunction.RandBetween(ValueLow, ValueHigh)
            
        'Pass value to the function
            GetRandomValue = x
    
    End Function
    

    And here is how I call the function to get a random row and a random column:

                        'Get random row
                            RandomRow = GetRandomValue(ValueLow:=BeginRow, _
                                                       ValueHigh:=EndRow)
                                                       
                        'Get random column
                            RandomColumn = GetRandomValue(ValueLow:=BeginColumn, _
                                                          ValueHigh:=EndColumn)
    

    Go There!

    Once I have a Row and Column number, I can use the Cells property of the Worksheet Object in conjunction with the GoTo Method of the Excel Application Object to go to the desired cell:

                        'Go to the cell
                            Application.GoTo ws.Cells(RandomRow, RandomColumn), _
                                                      Scroll:=True
    

    ActiveCellOutput

    Bam! I sent the Worksheet Name and the ActiveCell Address to the Immediate Window.

    Let’s Go!

    Recall, the end in mind is to set the ActiveCell to the same cell on every sheet to aid in our visual review of each worksheet in the workbook. I introduced the Code Snippet just a few lines up:

                        'Go to the cell
                            Application.GoTo ws.Cells(RandomRow, RandomColumn), _
                                                      Scroll:=True
    

    So I just need to pass 2 values of datatype long and I can go to any cell I want. So to GoTo R1C1 is merely:

                        'Go to the cell
                            Application.GoTo ws.Cells(1, 1), _
                                                      Scroll:=True
    

    Pow! The ActiveCell on every Worksheet is now R1C1 (A1). The review is much more pleasurable.

    But I want flexibility!

    What if you want to set the ActiveCell as $R$10 on every Worksheet, next time you want $C$12 – you get the point – enter the InputBox.

    Get Input

    I previously demonstrated a function to allow the user to select a cell here. Read more about using InputBoxes and the various types on MSDN

    For my purposes, I want the user to select a cell, so I will use Type:=8 for my InputBox:

    Public Function GetCell(ws As Worksheet) As Range
         
        'Declare variables
            Dim rng                         As Range
         
        'Users - select a cell on a worksheet
            Set rng = Application.InputBox( _
                                           Prompt:="Please select a cell on the worksheet", _
                                           Title:="Select a cell", _
                                           Default:=ActiveCell.Address, _
                                           Type:=8) 'Range selection
             
        'Pass the range object to the function
            Set GetCell = rng
         
        'Tidy up
            Set rng = Nothing
    
     End Function
    

    Now, I will test the GetCell Function:

    Option Explicit
    
    Sub testit()
    
        Dim wb As Workbook
        Dim ws As Worksheet
        Dim C As Range
        
        Set wb = ThisWorkbook
        Set ws = wb.Worksheets("PL_CC")
        Set C = GetCell(ws:=ws)
        
        Debug.Print C.Address
        
        Set C = Nothing
        Set ws = Nothing
        Set wb = Nothing
    
    End Sub
    

    And spin the test code:

    SelectCellPrompt

    I am prompted to select a cell on the worksheet. I clicked on cell $C$8.

    ClickCellOutput

    Shazam! That worked perfectly! I can move the Function into production and dynamically let the user choose what should be the ActiveCell on every Worksheet.

    Option Explicit
    
    Sub SetActiveCell()
        
        'Declare variables
            Dim wb As Workbook
            Dim ws As Worksheet
            Dim wsPL As Worksheet
            Dim C As Range
            Dim userRow As Long
            Dim userColumn As Long
        
        'Initialize
            Set wb = ThisWorkbook
            Set wsPL = wb.Worksheets("PL_CC")
            Set C = GetCell(ws:=wsPL)
        
            With C
                userRow = .Row
                userColumn = .Column
            End With
        
        'Set the ActiveCell on each worksheet
            For Each ws In wb.Worksheets
                If InStr(ws.Name, "PL") Then
                    Application.GoTo ws.Cells(userRow, userColumn), _
                                    Scroll:=True
                End If
            Next ws
        
        'Tidy up
            Set C = Nothing
            Set wsPL = Nothing
            Set wb = Nothing
            
    End Sub
    

    ActiveCellC8

    All worksheets with “PL” as part of the name are now active on cell $C$8. Much easier to review!

    Tidy Up

    I’m outta here. I just landed on Boardwalk and the kid has the monopoly with a hotel – I’m pretty sure I’m bankrupt!

    BankruptFinal

    , , , , , , , , ,