Mercury1940Final

I really like a lot of the Custom Hot Rods out there. Among my favorites are the Ford Mercuries that have been chopped with a Photon Laser and lowered. Among the Custom Hot Rod group the preference is for the 1951 Model. But I prefer the 1940 Model shown here with the hood coming to an apex, that awesome grille,split windshield and those enormous swooping fenders. Cars nowadays have by and large lost sight of these awesome design details. I hope to be able to find my own some day that I can restore and customize.

However, today’s post is not about the Ford Mercury or Custom Hot Rods, it’s about Excel Table TableStyles.

I like Excel Tables and Structured References a lot – 2nd only to PivotTables. If I can’t use a PivotTable, I’ll try to use an Excel Table and lastly a conventional cell-based formula. Today, I’ll look at TableStyles and some ideas on how to modify the TableStyles should you desire.

Get Some Data

First, I’ll need some data that I can convert to an Excel Table. To generate test data fast, I use the Random Data Generator Add-in by Dick Kusleika.

ExcelTableRange

Insert Excel Table

Now that I have a Range of data I can insert n Excel Table.

InsertTableFinal

I clicked on some cell in the Range, selected the Insert Menu and clicked on the Table icon in the Tables Group.

CreateTable

The Create Table dialog box pops up dispalying the CurrentRegion based on the cell I selected before I clicked on Insert Table. The check box for Headers defaults to True (checked) the Table includes Headers, so I’ll leave that as is.

ExcelTable1

When I click on a cell inside the Table the Table Tools Menu lights up.

TableToolsMenuFinal

I clicked on the Design Tab immediately below the Table Tools Menu. In the Table Styles Group, I notice that the Style that was applied to my Excel Table has a feint border around it. I hovered on the thumbnail image of the TableStyle and in the resulting Tool Tip discovered that the name of the TableStyle is Table Style Medium 2.

TableStyleMed2Final

TableStyles

TableStyleFlyout

I clicked on the Table Styles flyout to reveal thumbnail images of all of the different TableStyles. I hovered over each thumbnail with my mouse and the Style was applied to my Table offering a preview of what it would look like if I apply the Style – that’s a nice feature.

I discovered that I do not care for most of the Styles in the Table Style Gallery. Table Style Medium 1-14 are OK – chuck the rest.

TableStyles-Customize

Table Style Medium 1-14 are OK – but maybe I can make them a little better with a little customization. To customize an existing TableStyle, I need to duplicate the Style.

TableStyleCustomize



TableStyleModify

In the resulting Modify Table Style Dialog Box, give the copy of the Style you are duplicating a new name. In the screen shot, I am using tsDataProse3 becuase I already have a couple of Custom Styles in the Workbook.

TableStyleCustomGroup

I now have a Custom Group in the Table Style Gallery in addition to the Groupings for Light, Medium and Dark Table Style Collections.

Now that I have a Custom Style – I can change it however I want. As mentioned I like Table Style Medium 2 – but there are a couple of changes I would like.

  • Add thin white borders to interiors left and right for each Field in the Header Row
  • Add thin white borders to interiors left and right for each Row that has a Banded Color

TableStyleModifyHeaderFinal

I right-clicked on my Custom Style, tsDataProse3, selected Modify from the popup menu and selected Header Row in the Table Element ListBox.

Steps to modify the Header Row:

  • Click on the Format Button
  • In the Format Cells Dialog Box click on the Border Tab
  • Click on the desired Line Style
  • On the Border Preview Diagram I clicked on the Vertical Inside Border

Now when I right-click on my Custom Style, tsDataProse3, selected Modify from the popup menu and selected Header Row in the Table Element ListBox – I see a small change in the ElementForatting textual description with the addition of InsideVertical Border.

TableStyleModifyHeaderBorderFinal

Here is the Header Row after formatting the Inside Vertical Border.

TableStyleModifyHeaderInsideVertFin

Next I want to add an Inside Vertical Border to the Banded Rows.

TableStyleNoVerticalBorderFinal

Steps to modify the First Row Strip (Banded Row):

  • Right-click on the thumbnail image of your Custom Table Style
  • On the pop-up menu, click on modify
  • In the Table Element ListBox, click on First Row Stripe
  • Click on the Format Button
  • On he Format Cells Dialog Box, click on the Border Tab
  • Select a color for the border, I chose White, Backgropund 1, Darker 15% (RGB 217,217,217)
  • Click on the middle border in the Preview Diagram
  • Click “OK” 2x

Now I have nice continuous Inside Vertical Borders for all Cells in the Table.

TableStyleVerticalBorderAddedFin

Next Steps…

In my next post, I’ll look at some VBA that we may implement when working with TableStyles.

Tidy up

The changes I made to the existing TableStyle are very subtle. Make no mistake, this is a conscious choice. I don’t like heavy borders and I largely follow the teachings of Stephen Few when it comes to the display of quantitative data. Check out Steve’s stuff on his blog, Perceptual Edge.

Other Excel Table Articles At dataprose.org

Other Excel Table Articles Around The Horn

, , , ,

CharlieBrownFinal

Here in the States – All Hallows’ Eve (Halloween) is quickly approaching. One of my favorite times of the year with leaves changing color, daylight getting shorter, a crispness in the air, football season is in full swing, and the Fall Classic (Major League Baseball) begins in a few weeks.

All Hallows’ Eve is a time for hobgobblery and apparitions of all sorts as with Charlie Brown and the Peanuts gang pictured here. Excel too has a ghost. In this post I’ll take a look at one and how we might put it to rest.

Worksheet UsedRange Property

The Worksheet Object has a UsedRange Property. Normally, we should be able to use this property so that we can quickly identify the entire UsedRange on the Worksheet without having to jump through a lot of hoops.

UsedRange1

Here is a Range of Cells with some data. We can quickly find the address of the UsedRange on the Worksheet:

Option Explicit

Sub GetUsedRangeAddress()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    
    Set wb = ThisWorkbook
    Set ws = wb.ActiveSheet
    Set rng = ws.UsedRange
    
    Debug.Print rng.Address
    
    Set rng = Nothing
    Set ws = Nothing
    Set wb = Nothing
End Sub

Output:

$A$1:$J$10

Great – that is what I expected. But what happens if I delete some data?

UsedRange…False/Positive

A false positive occurs when we test for data and Excel tells us that there is data when in fact there is not.

UsedRange2

Here is the same data as before, but I deleted the data from Columns $H:$J. Now I’ll respin the code and check results:

$A$1:$J$10

Hmmm…same results – that is not good – therefore:


    we cannot rely on the UsedRange Property of the Worksheet Object. We need a better way to find the TRUE used range of data


The Last Used Cell

We can use the Find Method of the Range Object to get the last cell on the Worksheet that contains any data:

Sub GetLastCell()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    
    Set wb = ThisWorkbook
    Set ws = wb.ActiveSheet

    With ws
        Set rng = .Cells.Find(What:="*", _
                              After:=.Cells(1, 1), _
                              LookIn:=xlFormulas, _
                              LookAt:=xlPart, _
                              SearchOrder:=xlByRows, _
                              SearchDirection:=xlPrevious, _
                              MatchCase:=False)
    End With
                                
    Debug.Print rng.Address
    
    Set rng = Nothing
    Set ws = Nothing
    Set wb = Nothing
End Sub

Output:

$G$10

Great – that’s what I was looking for. What happens if there is nothing on the Worksheet? I moved to a new worksheet in the Workbook and tried the code again:

UsedRangeError1

That’s not good. I need to revise my code a bit to handle cases where there is no data on the worksheet:

Sub GetLastCellHandleNoData()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    
    Set wb = ThisWorkbook
    Set ws = wb.ActiveSheet

    With ws
        Set rng = .Cells.Find(What:="*", _
                              After:=.Cells(1, 1), _
                              LookIn:=xlFormulas, _
                              LookAt:=xlPart, _
                              SearchOrder:=xlByRows, _
                              SearchDirection:=xlPrevious, _
                              MatchCase:=False)
    End With
    
    If Not rng Is Nothing Then
        Debug.Print rng.Address
    Else
        Debug.Print "There is no data on worksheet ", ws.Name
    End If
    
    Set rng = Nothing
    Set ws = Nothing
    Set wb = Nothing
End Sub

I tested the code on a Worksheet with data in $A$1:$G$10. Results:

$G$10

Great – that’s what I expected.

Next I tested on a Worksheet with no data. Results:

There is no data on worksheet Sheet2

Great – that’s what I expected.


    I tested the code on a wide variety of scenarios for data placement on the Worksheet. It appears to work for any possible scenario. Please let me know if your tests return unexpected results or errors.


I now have the last used Cell on the Worksheet. Now I need the first used Cell on the Worksheet.

The First Used Cell

For the first used Cell, I tested Cell(1,1) first and then the remainder of the Worksheet. When data was in Cell $A$1, beginning at $A$1 and searching was returning the next Cell address.

Sub GetFirstCell()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rng As Range
    
    Set wb = ThisWorkbook
    Set ws = wb.ActiveSheet

    With ws
        If Not IsEmpty(ws.Cells(1, 1)) Then
            Set rng = ws.Cells(1, 1)
        Else
            Set rng = .Cells.Find(What:="*", _
                                  After:=.Cells(1, 1), _
                                  LookIn:=xlFormulas, _
                                  LookAt:=xlPart, _
                                  SearchOrder:=xlByRows, _
                                  SearchDirection:=xlNext, _
                                  MatchCase:=False)
        End If
    End With
    
    If Not rng Is Nothing Then
        Debug.Print rng.Address
    Else
        Debug.Print "There is no data on worksheet ", ws.Name
    End If
    
    Set rng = Nothing
    Set ws = Nothing
    Set wb = Nothing
End Sub

Final Functions() and Subs()

The stuff above is fine, but it would be cool if we could develop a function to return the True Used Range. I developed a few Functions() and Subs() to that end.

Function..GetUserSelectedCell

I would like to prompt the user to select a cell and test if there is any data on the worksheets the cell is located on. This makes my code more efficient before I continue processing.

Here I am using the InputBox of the Application Object with Type 8 parameter to allow the user to select a cell for the InputBox. More on the Application.InputBox Method (Excel).

Public Function GetUserSelectedCell(strPrompt As String, _
                                    strTitle As String) As Range

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'GetUserSelectedCell
    'Returns a Range Object based on Cell user selects
    '
    'Parameters        :
    'strPrompt         :    A string variable.
    '                  :    Provide a question or statement to the user to take some action.
    'strTitle          :    A string variable.
    '                  :    Provide a title for the InputBox.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

     'Declare variables
        Dim rng                         As Range
        
    'Users - select a cell on a worksheet
        On Error Resume Next
        Set rng = Application.InputBox( _
                        Prompt:=strPrompt, _
                        Title:=strTitle, _
                        Default:=ActiveCell.Address, _
                        Type:=8) 'Range selection

        On Error GoTo 0
        
    'Activate the worksheet
        On Error Resume Next
        rng.Parent.Activate
        
    'Pass object to function
        Set GetUserSelectedCell = rng
     
    'Tidy up
        If Not rng Is Nothing Then Set rng = Nothing

 End Function

And here is how I call the Function in the final Sub()

    'Prompt user to select a cell on a worksheet
        Set rngUserCell = GetUserSelectedCell(strPrompt:="Please select a cell on a worksheet.", _
                                              strTitle:="Get Cell Selection From User")

Function..What if the user clicked cancel?

The user may choose to cancel at the InputBox, so we need to handle that possibility. In this Function() I am using a MsgBox to ask the user if they wish to try again. More on the MsgBox Function.

Public Function GetUserMessageResponse(strPrompt As String, _
                                       strTitle As String, _
                                       lngButtons As Long) As Long

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'GetUserMessageResponse
    'Returns a value as a Long DataType
    '
    'Parameters        :
    'strPrompt         :    Required. A string datatype.
    '                  :    Provide a question or statement to the user to take some action.
    'strTitle          :    A string datatype.
    '                  :    Provide a title for the InputBox.
    'lngButtons        :    A long datatype
    '                  :    Use one of the vba button type enumerations
    '                  :    vbOKOnly            0   OK button only                      <-Default value
    '                  :    vbOKCancel          1   OK and Cancel buttons
    '                  :    vbAbortRetryIgnore  2   Abort, Retry, and Ignore buttons
    '                  :    vbYesNoCancel       3   Yes, No, and Cancel buttons
    '                  :    vbYesNo             4   Yes and No buttons
    '                  :    vbRetryCancel       5   Retry and Cancel buttons
    'Information       :    The Message Box returns 1 of 7 values:
    '                  :    vbOK        1
    '                  :    vbCancel    2
    '                  :    vbAbort     3
    '                  :    vbRetry     4
    '                  :    vbIgnore    5
    '                  :    vbYes       6
    '                  :    vbNo        7
    '
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    'Declare variables
        Dim MsgBoxValue             As Long
     
    'Users - select a cell on a worksheet
        MsgBoxValue = MsgBox( _
                        Prompt:=strPrompt, _
                        Buttons:=lngButtons, _
                        Title:=strTitle)
                        
    'Handle user actions
        If MsgBoxValue <> vbYes Then
            MsgBoxValue = vbCancel
        End If
         
    'Pass value to function
        GetUserMessageResponse = MsgBoxValue

 End Function

Function..TestForData

Now that I have a Cell on a Worksheet, I need to test to see if there is any data on the Worksheet. In the Function below, I first check Cell(1,1) for any data, if that does not contain any data, then I check the rest of the worksheet.

Here I am using the Find Method of the Range Object to search for anything on the Worksheet. More on the Range.Find Method (Excel).

Public Function TestForData(ws As Worksheet) As Boolean

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'TestForData
    'Returns a boolean datatype
    'Checks to see that data exists in at least 1 Cell on a Worksheet
    '
    'Parameters        :
    'ws                :   Required, A Woksheet Object.
    '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    'Declare variables
        Dim rng As Range
    
    'Initialize values
        TestForData = False
        
    'Check the worsheet for data
        On Error Resume Next
        If Not IsEmpty(ws.Cells(1, 1)) Then
            Set rng = ws.Cells(1, 1)
        Else
            With ws
                Set rng = .Cells.Find(What:="*", _
                                      After:=.Cells(1, 1), _
                                      LookIn:=xlFormulas, _
                                      LookAt:=xlPart, _
                                      SearchOrder:=xlByRows, _
                                      SearchDirection:=xlPrevious, _
                                      MatchCase:=False)
            End With
        End If
    
    'Update function value if the worksheet contains data
        If Not rng Is Nothing Then TestForData = True
  
    'Tidy up
        Set rng = Nothing

End Function

And here is how I call the Function in the final Sub()

    'Check if the worksheet has any data
        blnFlag = TestForData(ws:=wsUserCell)

Function..Find First And Last Cells

So far, I have tested if the user clicked cancel or if the worksheet contains any data, at this point, I have passed those tests, so now I can get to the meat of it.

I have one Function to return either the first used Cell or the last used Cell – and that my friends is cool. I want my Functions() to be fast, efficient and flexible. I vary whether the Function() returns the last used Cell or first used Cell by passing a variable to the SearchDirection by using the values of the xlSearchDirection Enumeration: xlNext and xlPrevious.

When the SearchDirection is xlNext, the Function() returns the first used Cell. When the SearchDirection is xlPrevious, the Function() returns the last used Cell.

Public Function GetCell(ws As Worksheet, _
                        rng As Range, _
                        lngDirection As Long) As Range
                        
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'GetCell
    'Returns a Range Object based on a single Cell
    'The Cell is either the first Cell in a Range or the last Cell in a Range
    'The distinction is based on the parameter value passed to lngDirection by the user as either xlPrevious or xlNext
    '
    'Parameters        :
    'ws                :   Required, A Woksheet Object.
    'rng               :   Required, A Range Object.
    'lngDirection      :   Required, Either xlNext or xlPrevious.
    '                      Use xlPrevious when searching for the last used Cell.
    '                      Use xlNext when searching or the first used cell.
    '
    'Use               :   Find the last used Cell first
    '                  :   Pass the last used Cell as a Range Object to the function to determine the first used Cell
    '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    'Get range as a single cell
        With ws
            Select Case lngDirection
                Case xlNext
                    If Not IsEmpty(.Cells(1, 1)) Then
                        Set rng = .Cells(1, 1)
                    Else
                        Set rng = .Cells.Find(What:="*", _
                                              After:=rng, _
                                              LookIn:=xlFormulas, _
                                              LookAt:=xlPart, _
                                              SearchOrder:=xlByRows, _
                                              SearchDirection:=lngDirection, _
                                              MatchCase:=False)
                    End If
                Case xlPrevious
                    Set rng = .Cells.Find(What:="*", _
                                          After:=rng, _
                                          LookIn:=xlFormulas, _
                                          LookAt:=xlPart, _
                                          SearchOrder:=xlByRows, _
                                          SearchDirection:=lngDirection, _
                                          MatchCase:=False)
            End Select
        End With
        
    'Pass the range to the function
        Set GetCell = rng

    'Tidy up
        Set rng = Nothing

End Function

When I call the Function() to get the last used Cell, I pass Cell(1,1) to the Function() and appropriate enumeration value for SearchDirection:

            'Get last cell
                Set rngLastCell = GetCell(ws:=wsUserCell, _
                                          rng:=wsUserCell.Cells(1, 1), _
                                          lngDirection:=xlPrevious)

When I call the Function() to get the first used Cell, I pass the Range Object created in the first call to the Function() and appropriate enumeration value for SearchDirection:

            'Get first cell
                Set rngFirstCell = GetCell(ws:=wsUserCell, _
                                           rng:=rngLastCell, _
                                           lngDirection:=xlNext)

The Final Sub()…GetTrueUsedRange

And here’s the final Sub() to bring it all together:

Option Explicit
Sub GetTrueUsedRange()

    'Declare variables
        Dim wb As Workbook
        Dim wsUserCell As Worksheet
        Dim rngUserCell As Range
        Dim rngStart As Range
        Dim rngLastCell As Range
        Dim rngFirstCell As Range
        Dim rngTrueUsedRange As Range
        Dim blnDataExists As Boolean
        Dim lngMessageResponse As Long
        Dim lngFirstCellRow As Long
        Dim lngFirstCellColumn As Long
        Dim lngLastCellRow As Long
        Dim lngLastCellColumn As Long
    
    'Initialize
        Set wb = ThisWorkbook
    
    'Prompt user to select a cell on a worksheet
        Set rngUserCell = GetUserSelectedCell( _
                            strPrompt:="Please select a cell on a worksheet.", _
                            strTitle:="Get Cell Selection From User")
                                          
    'Get the worksheet that contains the cell the user selected
        If Not rngUserCell Is Nothing Then
            Set wsUserCell = rngUserCell.Parent
        Else
            lngMessageResponse = GetUserMessageResponse( _
                                    strPrompt:="The selected worksheet does not contain any data." & vbLf & _
                                               "Or you clicked ""Cancel.""" & vbLf & _
                                               "Would you like to try a different worksheet?", _
                                    strTitle:="Missing Data Warning", _
                                    lngButtons:=vbYesNo)
        End If
    
    'Check if the worksheet has any data
        blnDataExists = TestForData(ws:=wsUserCell)
        
    'If the worksheet does not have any data, ask the user to select a different worksheet or exit
        If blnDataExists = False Then
            lngMessageResponse = GetUserMessageResponse( _
                                    strPrompt:="The selected worksheet does not contain any data." & vbCrLf & _
                                               "Would you like to try a different worksheet?", _
                                    strTitle:="Missing Data Warning", _
                                    lngButtons:=vbYesNo)

            If lngMessageResponse = vbYes Then
                Call GetTrueUsedRange   'Recursive call
                Exit Sub
            Else
                MsgBox "You clicked ""No"" or ""Cancel"". Now exiting.", vbInformation, "No Data Warning"
                Exit Sub
            End If
        Else
        
            'Get last cell
                Set rngLastCell = GetCell(ws:=wsUserCell, _
                                          rng:=wsUserCell.Cells(1, 1), _
                                          lngDirection:=xlPrevious)
                With rngLastCell
                    lngLastCellRow = .Row
                    lngLastCellColumn = .Column
                End With
                
            'Get first cell
                Set rngFirstCell = GetCell(ws:=wsUserCell, _
                                           rng:=rngLastCell, _
                                           lngDirection:=xlNext)
                                           
                With rngFirstCell
                    lngFirstCellRow = .Row
                    lngFirstCellColumn = .Column
                End With
        
        End If
        
    'Create true used range
        Set wsUserCell = wb.ActiveSheet
        Debug.Print "Worksheet", wsUserCell.Name
        With wsUserCell
            Set rngTrueUsedRange = .Range(.Cells(lngFirstCellRow, lngFirstCellColumn), _
                                          .Cells(lngLastCellRow, lngLastCellColumn))
        End With
    
    'Results
        Debug.Print "True used range", rngTrueUsedRange.Address

    'Tidy up
        If Not rngUserCell Is Nothing Then Set rngUserCell = Nothing
        If Not rngStart Is Nothing Then Set rngStart = Nothing
        If Not rngLastCell Is Nothing Then Set rngLastCell = Nothing
        If Not rngFirstCell Is Nothing Then Set rngFirstCell = Nothing
        If Not rngTrueUsedRange Is Nothing Then Set rngTrueUsedRange = Nothing
        If Not wsUserCell Is Nothing Then Set wsUserCell = Nothing
        If Not wb Is Nothing Then Set wb = Nothing
End Sub

Tidy Up

I tested the Sub() on several different Worksheets with a variety of placement of data, no data and single cells of data. All tests returned correct expected results. Please let me know if your tests return incorrect results.

How do you find the True Used Range on your Worksheets?

, , , , ,

BearFF

In my last post on using ActiveX Data Objects (ADO) with Excel VBA, I demonstrated some code to load a Recordset, filter the Recordset using the Recordset’s Filter Prpoerty, and copy the Filtered Recordset to a Worksheet using the CopyFromRecordset Method of the Range Object.

I put a link to the blog post on the Excel VBA and Users Group on LinkedIn. To our good fortune, James Wilson was reading. James responded with some nice comments and some very good code of his own. I was impressed and asked James if he would like to do a write up to post on the blog.

James kindly accepted my offer as follows in James’ words. Take it away James!



Bringing the full power of SQL to bear in Excel

James Wilson
September 13, 2014

“I feel the need, the need for speed.” Top Gun

I love Excel, but sometimes you just want a bit more power to analyse your data. My favourite tool for analysing large quantities of data has always been SQL. While Microsoft includes MS Query in Excel out-of-the-box, it does have many limitations and is relatively slow. Using VBA and ADO is the next logical step.

The code below is the latest incarnation of a general purpose SQL function I’ve been using for the last five years or so. For me the data is the thing – I want to be able to start querying my data using SQL without having to start coding from scratch each time. Just copy and paste into a module in your workbook, and you’re ready to go.

Code first then some explanation:

Function SQL(ByVal SQLstr As String, ByVal Destination As String, Optional ByVal ConnectionString As String) As Boolean

    On Error GoTo ErrorHandler
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = False

    Dim myConnection As Object
    Dim myRecordSet As Object
    Dim myQueryTable As QueryTable

    ThisWorkbook.Sheets(Destination).Activate
    ThisWorkbook.Sheets(Destination).Cells.Delete

    If ConnectionString = "" Then ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 12.0"
    
    Set myConnection = CreateObject("ADODB.Connection")
    Set myRecordSet = CreateObject("ADODB.Recordset")
    
    myConnection.ConnectionString = ConnectionString
    myConnection.Open
    myRecordSet.ActiveConnection = ConnectionString
    myRecordSet.Source = SQLstr
    myRecordSet.Open
    
    Set myQueryTable = Sheets(Destination).QueryTables.Add(Connection:=myRecordSet, Destination:=Range("'" & Destination & "'!a1"))
    myQueryTable.Refresh
    
    If myRecordSet.State <> adStateClosed Then myRecordSet.Close
    If Not myRecordSet Is Nothing Then Set myRecordSet = Nothing
    If Not myConnection Is Nothing Then Set myConnection = Nothing
    
    Err.Clear
ErrorHandler:
    If Err Then
        Sheets(Destination).Cells(1, 1) = "SQL Error: " & Err.Description
        SQL = False
    Else
        SQL = True
    End If
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
End Function

I wrote this as a VBA function rather than a sub procedure, because I wanted to be able to trap errors in the calling procedure. It is a really a matter of preference whether you like your functions to return True or False (lines 28 and 30). I’ve chosen to return True if it worked, so I’d call it using coding something like:

Sub test()
    DidItWork = SQL("SELECT * FROM [Sheet1$] WHERE [Sheet1$].[date] > #01/03/2014#", "Sheet2")
    If DidItWork = False Then … 'Do some error handling
End Sub

Basically this function sets up an ADO link to a data source, executes an SQL query on that data, and returns the results of that query to a worksheet of our choice in the current workbook using a query table.

When you call this function (line 1), you pass a string with your SQL query, a string with the name of the worksheet you want the data to be returned to, and optionally a connection string to the data source. By default the data source is the workbook the code is in. That’s right – you can use SQL to query data in other tabs in the same workbook (make sure your workbook is saved first).

If you find that most of the time you are querying a corporate database or other data source, then you’d just tweak line 15 of the coding to default to the connection string to the data source you are using most often.

Lines 4 to 6 and 42 to 44 are just the standard VBA codes that you’d put in to speed up any bit of coding. If you are calling this function and have these bits of coding in the calling procedure, then you can safely delete these lines from this function.

Lines 8 to 10 are to set up a local connection and recordset object (we’re going to use ADO to get our data), and a query table (which we are going to use to return the results of the SQL query to Excel).

The way this function is written, your data output is always going to be a worksheet in the current workbook in Cell A1. You can have no other data in this worksheet as Lines 12 to 13 delete the contents of the worksheet, before it is refreshed again with the query table set up in Line 26.

Line 17 to 27 is the meat of the function, setting up an ADO link and returning the data using a query table.

Lines 29 to 31 are to tidy up objects and connections. Line 36 is to give you a clue if you’ve made an error in your SQL.

So I’ve a personal library function that allows me to use SQL in Excel without much further thought – what do I do with it? Let me give a few simple examples to give an idea of the possibilities.

  1. Treat my current spreadsheet a bit like a mini-database and run queries on it – that would be much harder to do just using VBA or manually copying and pasting.
  2. Suck data out of multiple corporate databases and spreadsheets and join it together. You don’t need even to open the spreadsheets to get the data (as I said to start with – it’s all about speed and power). So for example let’s say you have one spreadsheet from your sales guys with sales volumes, and you have another spreadsheet with the confidential prices for each customer, then you can do a bit of SQL coding like:
    DidItWork = SQL(“SELECT A.*, B.[Price], A.[Volume]*B.[Price] as [Revenue] from [C:\Sales Volumes.xlsx].[Data$] A LEFT OUTER JOIN [F:\Prices.xlsx].[Sheet1$] B ON A.[Product] = B.[Product] AND A.[Customer No] = B.[Customer] “, “Sales Forecast”)
    So I’m using SQL aliases A and B for brevity, and by using multipart identifiers specifying the full path and filename of the Excel workbooks I can suck data out of any file I have access to. Note if you specify the data source fully, the connection string ADO uses is virtually irrelevant.
  3. By using For…Next loops in VBA and a bit of text manipulation and the SQL command UNION I can consolidate multiple similar data sources simply. So using a string variable like below in a loop:

mySQLstring = mySQLstring & ” UNION ” & …
Good for consolidating budgets submitted in a similar format.

The limitation is really your knowledge of SQL. Beware of missing spaces and extra commas in your SQL if you are using the VBA & _ to join long strings together to form your SQL.


Tidy Up

Thanks James – great job! How do you use ADO, SQL, Recordsets and QueryTables in your Projects?

, , , , , , , , ,

SNLFinal

In Coffee Talk on Satruday Night Live, Linda Richman, played by Mike Myers would hurl out “Discussion Topics”. Here are a few of my favorites:

  1. “The Partridge Family were neither partridges, nor a family. Discuss.”
  2. “The radical reconstruction of the South after the Civil War was neither radical nor a reconstruction. Discuss.”
  3. “The jelly bean is neither made of jelly nor is it a bean. Discuss.”

However, today’s topic is not about SNL or the radical reconstruction of the south. It is about Excel.

Today’s discussion topic:

In their landmark tome, Professional Excel Development, 2nd Edition, Bovey et. al. contend that Row 1 and Column A should be left empty (Bovey et. al. pg. 70). I posit that it is fine to use Row 1 Column A (R1C1) for tabs in the Data Layer of the Workbook – Discuss.

,

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

    , , , , , , , , ,

    UndauntedFinalII

    Some time back, Shane Devenshire and I added our two cents to a question a user asked on LinkedIn here. So when I decided to write a post regarding UnPivot using nested For..Next Loops, it only made sense to ask Shane if he would like to write a guest-post and tutorial on his process and Normalization Utility.

    So, without further ado, take it away Shane!

    Un-pivoting Excel Spreadsheet data – Creating a Normalized Table

    Introduction:
    Recently I was working with Tableau and discovered that the company had an Excel add-in for taking data laid out like a pivot table or standard spreadsheet layout:

    SDTable1

    And converting it to data laid out like a table (normalized):

    SDTable2

    When I tested the add-in on a large data it took over an hour. I knew I could do this faster, even manually, but I decided to automate the process, which uses a number of Excel’s built-in features. The attached is the initial result of this endeavor.

    When one wants to convert spreadsheet data, laid out as in a pivot table, into what is called a normalized database or table one can use a VBA approach which loops through cells rearranging the data and copying repeated data as many times as necessary. You could do this manually but it’s rather labor intensive. However, even the looping approach is not very efficient, which becomes apparent when the data sets are large. An alternate approach using some of Excel’s less familiar features can speed up the process dramatically.

    I created the three step wizard shown below to provide some enhancements:

    In the first step, see Figure 1, the user indicates the top left corner of the values area, the sample show what we are looking for. This allows the VBA routine to decide where the column titles are and which columns will be retained in their default structure and which column will be “transposed” (placed in a singe “values” column.

    Figure 1 – First step of the Wizard:

    SDTable3

    If the user clicks Finish, the code accepts all the defaults and created the normalized table. If the user clicks Next the second step of the Wizard is displayed, see Figure 2.

    Figure 2 – This is the second step of the Wizard:

    SDTable4

    Here the Wizard displays the first ten fields to the left of the values area allowing the user to choose which ones to include. If there are dates at the top of the values area a default name for the new field is Date which is automatically entered in the Field Name box which the user can change or leave blank. The Delimiter box allows the user to indicate what delimiter to use when concatenating the fields together (discussed later). The delimiter should not be a character found in the chosen fields on the left in the dialog box.

    Clicking Next brings you to the third step of the wizard, shown in Figure 3.

    Figure 3 – This is the third step of the Wizard:

    SDTable5

    The first two options on this screen allow the user to retain or remove rows of data in the output table which have either a 0 (zero) or are blank in the values column. This reduces the file size when appropriate. Because the Excel feature used to normalize the data generates an Excel “table”, the last three options allow the user to turn on or off various features of tables or convert the table to a range.

    Overview:

    You can create a pivot table in Excel with a feature called Multiple Consolidation Ranges. You can then use the Show Details command on the Grand/Grand Total to produce a normalized table. Both of these commands are very fast! One limitation of this command is that is was designed to be used with data which has only one label field to the left of the values area. To bypass this limitation one can combine all the label fields by using a concatenation formula, but to later break it apart a delimiter is need. Then the multiple consolidation command is run against this one field and all of the value columns. The concatenated field of the output is then parsed using Excel’s Text to Columns command with the delimiter specified by the user. These steps are very fast. As noted in the discussion of step 3 of the Wizard, I have also incorporated a number of additional options.

    I create two modules and a user form to control this process. All of the code and form can be found in the attached file. I have tried not to obfuscate the code. There are four main components to consider

    Option Explicit		
    Dim k	As Integer	number of fields to be output
    		
    Sub NormalizeData()		
    Dim sTempSheet	As String	Name of the sheet where the pivot table is placed
    Dim j	As Integer	loop counter
    Dim i	As Integer	loop counter
    Dim sMyFormula	As String	the concatenated formula
    Dim sMySheet	As String	Name of the sheet where initial data is
    Dim lMyColumn	As Long	column number of column used for concatenated formula
    Dim sDataSheet	As String	Name of the sheet where the final output is placed
    Dim sSource	As String	Source range for the pivot table
    Dim sMyTitles	As String	The concatenated titles
        		
        'Speeds things up		
        With Application		
            .ScreenUpdating = False	
            .Calculation = xlCalculationManual	
        End With		
        		
        sMySheet = ActiveSheet.Name	
        		
        'uses the ref edit address to place the cursor in the top left corner of the values to be transposed
        Range(frmNormalize.refFirstData).Activate
        		
        'Inserts new blank column for concatenation formula
        ActiveCell.EntireColumn.Insert	
        lMyColumn = ActiveCell.Column	
        		
        'initializes loop counters		
        j = 1		
        k = 0		
        		
        'loops through each column and concatenates it if that column was choosen
        'this loop runs a max of ten times	
        For i = iTotCols To 1 Step -1	
            If frmNormalize.Controls("Checkbox" & j) = True Then
                If sMyFormula = "" Then	
                    sMyFormula = "=RC[" & -i & "]"	
                Else		
                    sMyFormula = sMyFormula & "&" & """" & sDelimiter & """" & "&RC[" & -i & "]"
                End If		
                k = k + 1		
            End If		
            j = j + 1		
        Next i		
    

    The above code creates a concatenation formula of the forma =A5&”*”&B5&”*”&C5, which is then converted to values like 2008*Coffee*Seattle. The above code loops once to build the concatenated formula for a single row, and then fills it down. All very fast. The delimiter must be unique because it will be used by the Text to Columns command to parse the data.

        'Selects the title row and inserts the formula there.
        'Here it will be the concatenated titles	
        ActiveCell.Offset(-1, 0).Select	
        ActiveCell = sMyFormula		
        Range(ActiveCell, Cells(lLastRow, ActiveCell.Column)).FillDown
        ActiveSheet.Calculate		
        		
        'converts the range to values	
        Selection = Selection.Value	
        		
        'the concatenated titles is saved for later use since it would be lost during the next commands
        sMyTitles = ActiveCell		
        		
        'Creates "consolidated ranges" pivot table, which will later be removed
        sSource = Range(Cells(lFirstDataRow - 1, lFirstDataColumn), Cells(lLastRow, lLastColumn)).Address(, , xlR1C1)
        ActiveWorkbook.PivotCaches.Create(SourceType:=xlConsolidation, _
            SourceData:=sSource).CreatePivotTable _
            TableDestination:="", _	
           TableName:="NPT"		
        On Error Resume Next	
        ActiveSheet.PivotTables("NPT").PivotFields("Count of Value").Function = xlSum
    

    The above code is one of the steps that make this process so fast. Excel builds a “consolidated range” pivot table. If some of the data is non-numeric the data field would use “Count” which we want to convert to “Sum”, this is the reason for lines 67 and 68. Manually you can reach this command by pressing Alt+D+P to expose the PivotTable and PivotChart Wizard from Excel 2003, shown in Figure 4, below:

    Figure 4 – This is the first step of Microsoft’s Wizard, which the code is emulating:

    SDTable6

    The command we are using is Multiple consolidation ranges. Excel gives us a pivot table which Is, in and of itself, not very useful. But in the following code, the ShowDetail command used on the Grand/Grand Total creates the desired output. And it’s very fast!

        'creates database detail from the above pivot table, which is pretty much what we want
        sTempSheet = ActiveSheet.Name	
        ActiveCell.SpecialCells(xlLastCell).ShowDetail = True   'Generates normalized database
        		
        'you can turn off these alerts earlier in the macro but its often safer to turn them of and on only where needed
        ‘The pivot table sheet is no longer need and can be deleted
        With Application		
            .DisplayAlerts = False		
            Sheets(sTempSheet).Delete	
            .DisplayAlerts = True
    

    The following code first inserts some blank columns and then uses Excel’s Text to Columns command to convert the concatenated field back to its original individual fields. Yet another very fast command!

            'inserts as many columns as need to display all the concatenated fields
            Range("B1:" & Cells(1, k).Address).EntireColumn.Insert
            'puts the concatenated titles in cell A1
            Range("A1") = sMyTitles
            Range("A1", [A1].End(xlDown)).Select
            
            'the text to columns command overwrites the table's default titles
            .DisplayAlerts = False
        
            'converts concatenated field to a set of columns
            Selection.TextToColumns _
                Destination:=Range("A1"), _
                DataType:=xlDelimited, _
                ConsecutiveDelimiter:=False, _
                Other:=True, _
                OtherChar:=sDelimiter
            .DisplayAlerts = True
        End With
        
        'best fit the data
        Range("A1:" & Cells(1, iTotCols).Address).EntireColumn.AutoFit
        
        'enters the field name for the transposed row
        Range("A1").Offset(0, k) = frmNormalize.txtNewFieldName
        
        'Options - removes rows With blanks or zeros in the value field
        If frmNormalize.cbBlanks = True Then
            RemoveBlanks
        End If
        If frmNormalize.cbZeros = True Then
            RemoveZeros
        End If
        ConvertToRange
        
        'Cleanup
        sDataSheet = ActiveSheet.Name
        Sheets(sMySheet).Activate
    
       ‘removes the concatenated formula column from the original data.
        Cells(1, lMyColumn).EntireColumn.Delete    
        Sheets(sDataSheet).Activate
        Application.Calculation = xlCalculationAutomatic
        
    End Sub
    

    Deleting rows can be done by looping from the bottom and deleting each row that meets a given condition. This is very slow! If you can select all the rows which meet some condition you can then delete them with one command. This is faster. However, if Excel needs to adjust cell references based on the deleted rows this can also slow things down. One solution is to move all the rows you want to delete to the bottom of the dataset and then delete them with a single command. In the following two modules something like that is done. For removing rows with blanks in the values column you simple need to sort by the values and the use the Go to Special, Blanks command to select all the rows.

    RemoveBlanks Subroutine

    Removes rows with blanks in value column
    Private Sub RemoveBlanks()
        
        'puts all blank cells at the bottom of the table making deleting rows faster
        With ActiveSheet.Sort
            .SortFields.Clear
            .SortFields.Add _
                Key:=Cells(1, k + 2), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending
            .SetRange ActiveCell.CurrentRegion
            .Header = xlYes
            .Orientation = xlTopToBottom
            .Apply
        End With
        
        'this command deletes all rows with blanks in the values column
        Selection.Offset(0, k + 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End Sub
    

    Removing zeros is a little trickier, because, if the user has chosen not to remove blanks you can’t clear all cells with 0’s and then run the above command, extra row may be deleted. In this case you can replace the 0’s with text, then clear the cells with zeros and then use line 18 above to remove the rows. Finally you can clear the cells containing text. I chose not to do that; instead I entered the formula =1/0 in all the cells with 0 and then sorted putting this group near the bottom. Then I selected an deleted all the cells with error formulas with one step, line 25.

    RemoveZeros Subroutine

    This code removes all rows with zeros in the values field
    Private Sub RemoveZeros()
        
        'replaces all cells with 0 with a formula generating an DIV/0! error
        Range("A1").CurrentRegion.Resize(, 1).Offset(0, k + 1).Select
            Selection.Replace _
                What:="0", _
                Replacement:="=1/0", _
                LookAt:=xlWhole
            
        'this sorts all cells with errors to the bottom making deleting rows faster
        With ActiveSheet.Sort
            .SortFields.Clear
            .SortFields.Add _
                Key:=Cells(1, k + 2), _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending
            .SetRange ActiveCell.CurrentRegion
            .Header = xlYes
            .Orientation = xlTopToBottom
            .Apply
        End With
        
        'this command deletes all rows with errors
        Selection.SpecialCells(xlCellTypeFormulas, 16).EntireRow.Delete
    End Sub
    

    ConvertToRange Subroutine

    'The user can keep the table or convert it to a regular spreadsheet range
    'The user can keep or remove the autofilters in either case
    'The user can keep or remove the formatting in either case
    Private Sub ConvertToRange()
        Dim rList As Range
     
        With ActiveSheet.ListObjects(1)
            Set rList = .Range
            If frmNormalize.cbConvertToRange = True Then
                .Unlist                                                                     'converts a table to a range
                If frmNormalize.cbFilter = False Then Range("A1").CurrentRegion.AutoFilter  'turns on  autofilter
                If frmNormalize.cbFormatting = True Then                                    'removes table formatting
                    With rList
                        .Interior.ColorIndex = xlColorIndexNone
                        .Font.ColorIndex = xlColorIndexAutomatic
                        .Borders.LineStyle = xlLineStyleNone
                    End With
                End If
            Else
                If frmNormalize.cbFilter = True Then .Range.AutoFilter  'Turns off autofilter
                If frmNormalize.cbFormatting = True Then                'Turns off table formatting
                    .TableStyle = ""
                End If
            End If
        End With
    End Sub
    

    Tidy Up

    That’s it for today. HUGE thanks to Shane Devenshire for sharing his Data Normalization Utility with us and allowing me to post it on my blog. I hope you enjoy it and find it useful in your daily work.

    Downloads

    Download the file from OneDrive. The zip archive contains the Data Normalizer in .xlsm format as well as a Microsoft Word version of the tutorial.

    Other posts regarding data normalization or “UnPivot” at dataprose.org

      Undaunted by UnPivot

    Other posts regarding data normalization or “UnPivot” around the horn

      UnPivot Shootout – DDoE
      Reshape Data
    , ,

    UndauntedFinal

    Well, maybe an UnPivot or Reverse CrossTab process in Excel with VBA does not require the same amount of courage as Meriwether Lewis (pictured here) must have had as he and Clark set out on their exploration of the Louisiana Territory – nonetheless, the process can seem a bit overwhelming to a newcomer. I’ll do my best to explain it in a straight-forward manner.

    Many times, we receive data in a crosstab format but we want it in a normalized format suitable for use with Pivot Tables or Excel Tables :

    Crosstab

    Here’s a fairly standard layout to retrieve data from a P&L Cube in Essbase using the Essbase Spreadsheet Add-in. This layout, however, is not conducive for creating PivotTables or for analyzing with Excel Tables. There are ways in Essbase to get this is a better “Normalized” format, but I have this at hand so it suits my needs for now.

    Tell Me What You Need….

    CrosstabMarkup

    I marked-up the spreadsheet to show which fields I am interested in and in what order I would like them in the final output :

    1. Organization – Some division, region, district, store in the company under analysis
    2. Scenario – Budget, Forecast, Actual and various versions of the aforementioned
    3. Time – I’m showing periods in the screen shot, could be any measure of time
    4. Accounts – The name and or number of the account
    5. Measure – What we are really interested in : Amounts, statistics, ratios, etc…

    How Would You Like That….

    Here is the desired output :

    CrosstabOutput

    Some of the values in the desired output are static, that is, the same value from the same cell must be output over and over again. Other times, I need to move across columns and still others I need to move down rows

    Segue To Some Functions…

    I’ll need a coupe of Functions so that my code is dynamic to some extent. I do not know the last column or the last row during development stage so I will need to determine those values at run-time.

    Last Used Column

    This function has only one argument, a worksheet, it will return the column number of the last used cell on the worksheet

    Public Function GetLastColumn(ws As Worksheet) As Long
    
        'Input  :   Worksheet
        'Output :   A column number of type long
        
        'Declare variables
            Dim rng As Range
            Dim lngColumn As Long
            
        'Get range address of last cell on worksheet
            Set rng = ws.Cells.SpecialCells(xlCellTypeLastCell)
        
        'Get column number of last cell
            lngColumn = rng.Column
            
        'Pass value to function
            GetLastColumn = lngColumn
        
        'Tidy up
            Set rng = Nothing
            
    End Function
    

    Last Used Row

    This function has only one argument, a worksheet, it will return the row number of the last used cell in Column A :

    Public Function GetRows(ws As Worksheet) As Long
    
        'Input          :   Worksheet
        'Output         :   A row number of type long
        'Assumptions    :   First column (A)
        
        'Declare variables
            Dim r As Long
        
        'Get last row
            With ws
                r = .Cells(Rows.Count, 1).End(xlUp).Row
            End With
            
        'Pass value to function
            GetRows = r
            
    End Function
    

    The Main Procedure

    Here is the main procedure. The main thing to pay attention to is the different variable and static cell values used to get the correct output. Take a look at the code inside the For..Next Loops :

    Option Explicit
    
    Sub UnPivotData()
    
        'Purpose    :   Convert crosstab data to normalized data
        'Author     :   Winston Snyder
        'Date       :   5/26/2014
    
        'Declare variables
            Dim wb As Workbook
            Dim wsData As Worksheet
            Dim wsDataNormalized As Worksheet
            Dim MaxColumns As Long
            Dim MaxRows As Long
            Dim i As Long
            Dim j As Long
            Dim k As Long
    
        'Excel environment - speed things up
            With Application
                .ScreenUpdating = False
                .DisplayAlerts = False
                .EnableEvents = False
                .Calculation = xlCalculationManual
            End With
    
        'Objects
            Set wb = ThisWorkbook
            With wb
                Set wsData = .Worksheets("Data")
                Set wsDataNormalized = .Worksheets("Normal")
            End With
    
        'Initialize
            wsDataNormalized.UsedRange.ClearContents
            MaxColumns = GetLastColumn(ws:=wsData)
            MaxRows = GetRows(ws:=wsData)
            k = 2
    
        'Convert cross-tab report to normalized data table structure
            With wsDataNormalized
                For i = 6 To MaxRows 'Begin with first row of (Measures)
                    For j = 2 To MaxColumns 'Begin with first column of data (Measures)
                        .Cells(k, 1).Value = wsData.Cells(4, 1).Value   'Organization
                        .Cells(k, 2).Value = wsData.Cells(2, 1).Value   'Scenario
                        .Cells(k, 3).Value = wsData.Cells(5, j).Value  'Time
                        .Cells(k, 4).Value = wsData.Cells(i, 1).Value  'Account
                        .Cells(k, 5).Value = wsData.Cells(i, j).Value  'Measure
                        k = k + 1
                    Next j
                Next i
    
                'Add headers
                .Range("A1").Value = "Organization"
                .Range("B1").Value = "Scenario"
                .Range("C1").Value = "Time"
                .Range("D1").Value = "Account"
                .Range("E1").Value = "Measure"
            End With
    
        'Tidy up
            'Destroy objects
                Set wsDataNormalized = Nothing
                Set wsData = Nothing
                Set wb = Nothing
    
            'Restore Excel environment
                With Application
                    .ScreenUpdating = True
                    .DisplayAlerts = True
                    .EnableEvents = True
                    .Calculation = xlCalculationAutomatic
                End With
    End Sub
    

    CrosstabOutputNormal

    Perfect Ready to Pivot or analyze with Excel Tables an Structured Reference Formulas.

    It’s About Time….

    I’m going to add a couple of lines to the Sub() to see how long it takes. I’ll use the GetTickCount function from the Windows kernel32 library :

    Option Explicit
    Public Declare Function GetTickCount Lib "kernel32.dll" () As Long
    
    Sub UnPivotData()
    
        'Purpose    :   Convert crosstab data to normalized data
        'Author     :   Winston Snyder
        'Date       :   5/26/2014
        
        'Start timer
            Dim t As Long
            t = GetTickCount
    
        'Declare variables
            Dim wb As Workbook
            Dim wsData As Worksheet
            Dim wsDataNormalized As Worksheet
            Dim MaxColumns As Long
            Dim MaxRows As Long
            Dim i As Long
            Dim j As Long
            Dim k As Long
    
        'Excel environment - speed things up
            With Application
                .ScreenUpdating = False
                .DisplayAlerts = False
                .EnableEvents = False
                .Calculation = xlCalculationManual
            End With
    
        'Objects
            Set wb = ThisWorkbook
            With wb
                Set wsData = .Worksheets("Data")
                Set wsDataNormalized = .Worksheets("Normal")
            End With
    
        'Initialize
            wsDataNormalized.UsedRange.ClearContents
            MaxColumns = GetLastColumn(ws:=wsData)
            MaxRows = GetRows(ws:=wsData)
            k = 2
    
        'Convert cross-tab report to normalized data table structure
            With wsDataNormalized
                For i = 6 To MaxRows 'Begin with first row of (Measures)
                    For j = 2 To MaxColumns 'Begin with first column of data (Measures)
                        .Cells(k, 1).Value = wsData.Cells(4, 1).Value   'Organization
                        .Cells(k, 2).Value = wsData.Cells(2, 1).Value   'Scenario
                        .Cells(k, 3).Value = wsData.Cells(5, j).Value  'Time
                        .Cells(k, 4).Value = wsData.Cells(i, 1).Value  'Account
                        .Cells(k, 5).Value = wsData.Cells(i, j).Value  'Measure
                        k = k + 1
                    Next j
                Next i
    
                'Add headers
                .Range("A1").Value = "Organization"
                .Range("B1").Value = "Scenario"
                .Range("C1").Value = "Time"
                .Range("D1").Value = "Account"
                .Range("E1").Value = "Measure"
            End With
    
        'Tidy up
            'Destroy objects
                Set wsDataNormalized = Nothing
                Set wsData = Nothing
                Set wb = Nothing
    
            'Restore Excel environment
                With Application
                    .ScreenUpdating = True
                    .DisplayAlerts = True
                    .EnableEvents = True
                    .Calculation = xlCalculationAutomatic
                End With
                
        'Timer
            MsgBox GetTickCount - t & " Milliseconds", , " Milliseconds"
    
    End Sub
    

    I ran three trials of the revised code to check the timer. It ran in 62 ms, 78 ms and 62 ms respectively.

    Tidy Up

      UnPivot

        UnPivot Shootout – DDoE
        Reshape Data

      Essbase

        Hyperion Essbase
        Hyperion Essbase Spreadsheet Add-In

      kernel32.dll

        kernel32.dll
        kernel32 documentation
      ,

    Pre3

    Here’s Bill Bowerman (facing) with Steve “Pre” Prefontaine (back turned). Pre was an amazing long distance runner, at one point in his career holding 9 different long distance running records. 4 of Pre’s records remain unbroken to this day. Pre died in an automobile accident in May, 1975. He was only 24 years old.

    Bowerman and one of his former student athletes founded Blue Ribbon Sports which eventually became Nike, [Just Do It]

    The 1997 movie, Prefontaine stars Jared Leto as Pre and R. Lee Ermey as Bowerman. Ermey is always entertaining in everything he does in his over the top approach and larger than life portrayals, check it out.

    Today’s post, however, is not about running or movies, it is about the DoCmd Object of the Access Object Model. The DoCmd Object has 66 different Methods as of Office 2013. I’ll look at some of the Methods over a series of posts and how they may be leveraged in Microsoft Office development. I’ll begin with the TransferSpreadsheet Method.

    I won’t bore you by reviewing the parameters of the Method, you can read those for yourself here. Instead, I’ll jump right in and demonstrate some VBA you may use to update your Access Tables from Excel Worksheets.


      edit: This is a re-boot of sorts. Readers of this blog (both of you) will recall I posted an article back in November, 2013. That article was lost to the cybersphere during the great melt down of aught thirteen when I hosed my function.php file.


    TransferSpreadsheet Method

    I want to transfer a list of NFL teams from an Excel Worksheet to a Table in an Access Database. This will be a Dimension (Dim) Table, so all I need in the Table is a Primary Key and the name of each Team. I will want to automate this routine and attempt to insert any number of teams at any time based on transformative process I use in Excel to create files that I will want to attempt to insert into the Team Dimension Table. It is imperative that a team only exist 1 time in the Dimension (dim) Table.

    tblTeamsPK

    I created the table and named it dimTeams. I named the first field TeamKey, set the field as the Primary Key for the table and set the datatype to autonumber.

    tblTeamsDesignFieldPropertiesFinal

    Next, I added the field, TeamName, set the datatype to Short Text, and in the Field Properties pane, changed the Indexed property to Yes (No Duplicates). I saved all changes to the table. I am now ready to add some VBA to Load the table using DoCmd.TransferSpreadsheet.

    DoCmd.TransferSpreadsheet VBA

    Option Compare Database
    
    Sub TransferSpreadsheet()
        'Author: Winston Snyder
        'Date: 4/5/2014
        'Purpose: Transfer Excel Worksheet to Access Table
        
        'Declare variables
            Const strPATH   As String = "C:\tmp\"
            Const strFILE   As String = "xlTeams.xlsx"
            Const strTABLE  As String = "dimTeams"
    
        With DoCmd
            'Turn warnings off
                .SetWarnings False
    
            'Transfer spreadsheet
                .TransferSpreadsheet _
                    TransferType:=acImport, _
                    TableName:=strTABLE, _
                    FileName:=strPATH & strFILE, _
                    HasFieldNames:=True
    
            'Turn warnings on
                .SetWarnings True
                
        End With
        
    End Sub
    

    dimTeamsLoadedFinal

    That works well. All current 32 teams of the NFL were loaded to the dimTeams Table. I’ll try to load the Table again. Recall, I set the Index property to Yes (No Duplicates) so no duplicate values should be loaded to the Dimension Table. I’ll comment out the 2 lines in code that turn warning messages off and back on so I can review any error messages :

            'Turn warnings off
                '.SetWarnings False
    
            'Turn warnings on
                '.SetWarnings True
    

    Here is the information message I receive from Access when I re-spin the code :

    UnableToAppend

    Because I set the Index property on the TeamName field, to Yes (No Duplicates), all 32 records are rejected and nothing additional is loaded. Next, I’ll amend the Excel Workbook to add teams from the now defunct NFL Europe just so I can test that teams will indeed be added if new teams are added to the Excel Workbook.

    xlNFLEuropeTeams

    I added 9 teams from NFL Europe to the Excel Workbook and ran the VBA code again :

    dimTeamsTableUpdateFinal

    Only the 9 new team names from the Excel Workbook were added to the dimTeams table. Everything is working as I intended. I deleted everything from the dimTeams table and Compacted and Repaired the Database to force autonumbering to start at 1 again on the next step.

    Make The VBA More Dynamic / Flexible

    I don’t like that I hard-coded in VBA Code the file path, the file name and the table name. I’ll introduce some functions to make the code a bit more flexible and dynamic.

    FileDialogFilePicker

    I have discussed the FileDialog Property of the Application Object in previous posts. FileDialog’s are a great way to interact with users at run-time to allow the user to select a file to perform operations on.

    First, I added these 4 global constants to my Globals Module. These constants are based on the MSOFileDialogType Enumeration

    Public Const gclmsoFileDialogFilePicker = 3                 'File Picker
    Public Const gclmsoFileDialogFolderPicker = 4               'Folder Picker
    Public Const gclmsoFileDialogOpen = 1                       'Open
    Public Const gclmsoFileDialogSaveAs = 2                     'SaveAs
    
    Public Function GetSelectedFile() As String
         
        'Declare variables
            Dim fd                  As Object
            Dim strFileName         As String
     
        'Initialize variables
            Set fd = Application.FileDialog(gclmsoFileDialogFilePicker)
        
        'User - select file
            With fd
                .AllowMultiSelect = False
                .Show
                strFileName = .SelectedItems(1)
            End With
     
        'Pass value to function
            GetSelectedFile = strFileName
            
        'Tidy up
            Set fd = Nothing
        
    End Function
    

    I selected the file, “xlTeams.xlsx”. The function returns :

    C:\tmp\xlTeams.xlsx

    So I’ll need a functions to split the folder path and file name into separate substrings.

    GetSegmentsFromFullFileName

    This function returns either a substring of either the path or the file name. If the user specifies, “strSubstringType:=Path”, then the path will be returned. Otherwise the file name without the path will be returned.

    Public Function GetSegmentsFromFullFileName(strCompleteFileName As String, _
                                                strSubstringType As String) As String
    
        'Declare variables
            Dim strSegment As String
    
        'Get substring segment
            Select Case strSubstringType
                Case "Path"
                    strSegment = Mid(strCompleteFileName, 1, InStrRev(strCompleteFileName, "\"))
                Case Else
                    strSegment = Trim(Mid(strCompleteFileName, InStrRev(strCompleteFileName, "\") + 1, Len(strCompleteFileName) - InStrRev(strCompleteFileName, "\")))
            End Select
        
        'Pass value to function
            GetSegmentsFromFullFileName = strSegment
    
    End Function
    

    I selected the file, “xlTeams.xlsx”. The function returns either:

    C:\tmp\ or xlTeams.xlsx depending on the value the user passes for “strSubstringType”

    I need one more function to take the file name and convert it to the Access Table Name.

    GetTableNameFromFileName

    Public Function GetTableName(strFile As String) As String
    
        'Declare variables
            Dim strTable As String
    
        'Get table name from file name
        'In Len, include front and end segments to drop
            strTable = "dim" & Trim(Mid(strFile, 4, Len(strFile) - 7))
    
        'Pass the value to a function
            GetTableName = strTable
    End Function
    

    The function returns :

    dimTeams

    Now I just need to revise the original sub procedure to use the functions instead of hard-coding in values for the path, the file name and the name of the Access Table.

    TransferSpreadsheetUsingFunctions

    Sub TransferSpreadsheetUsingFunctions()
    
        'Purpose: Transfer Excel Worksheet to Access Table
        'Log    :
        '---------------------------------------------------------------------------------------------------------------------------------------------------
        'Date               Developer                   Action                      Comments
        '---------------------------------------------------------------------------------------------------------------------------------------------------
        '4/5/2014           ws                          Created
        '4/6/2014           ws                          Modified                    Added functions to remove hard-coding of path, file name and table name
        
        'Declare variables
            Dim strFullFileName             As String
            Dim strPath                     As String
            Dim strFileNameSubstring        As String
            Dim strTable                    As String
    
        'Initialize variables
            'User - call file dialog to get file
                strFullFileName = GetSelectedFile()
                
            'Get folder path from full file name
                strPath = GetSegmentsFromFullFileName(strCompleteFileName:=strFullFileName, _
                                                      strSubstringType:="Path")
                
            'Get file name substring from full file name
                strFileNameSubstring = GetSegmentsFromFullFileName(strCompleteFileName:=strFullFileName, _
                                                                   strSubstringType:="File")
                
            'Get Access Table name from the file name
                strTableName = GetTableName(strFile:=strFileNameSubstring)
                
        'Transfer spreadsheet to table
            With DoCmd
                'Turn warnings off
                    .SetWarnings False
        
                'Transfer spreadsheet
                    .TransferSpreadsheet _
                        TransferType:=acImport, _
                        TableName:=strTableName, _
                        Filename:=strPath & strFileNameSubstring, _
                        HasFieldNames:=True
        
                'Turn warnings on
                    .SetWarnings True
                    
            End With
        
    End Sub
    

    dimTeamsLoadFinal

    Great! That works well. The dimTeams Table is once again loaded. But what if there is more than one file to load?

    Multiple Files…Multiple Tables

    So far, so good. But chances are good you may have multiple files to load to multiple tables. I have code above to load one file to one table, so now I just need to add the ability to loop through files in a folder and load each file while I am looping.

    LoadFilesToTables2

    To loop through files in a folder, I like to use the FileSystemObject (FSO) which is a top level object in Microsoft Scripting Runtime Library (scrrun.dll). I covered FSO previously as part of my series on Microsoft Scripting in VBA.


      edit: As per usual, 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


    Some New Functions

    I’ll need some new functions to create the FileSystemObject (FSO) and to work with the FileDialog Object.

    Create FileSystemObject

    This function creates a FileSystemObject. This is the route to go if you are using Late Binding for creating an object.

    Public Function GetFileSystemObject() As Object
          
        On Error Resume Next
        Set GetFileSystemObject = CreateObject("Scripting.FileSystemObject")
          
    End Function
    

    File Dialog

    I modified the FileDialog Function I introduced earlier. The function now accepts one argument, “strDialogType” so the function may be used to return either the name of a folder or the name of a file based on the value of strDialogType as declared by the user :

    Public Function GetFDObjectName(strDialogType As String) As String
    
        'Returns either the name of a folder or the name of a file based on the type passed into the function, "strDialogType"
      
        'Declare variables
            Dim fd As FileDialog
            Dim strObjectName As String
            Dim strTitle As String
            
        'Choose if user requested a folder dialog or other
            Select Case strDialogType
                Case "Folder"                                                               'Folder Dialog
                    strTitle = "Please select a folder"
                    Set fd = Application.FileDialog(gclmsoFileDialogFolderPicker)
                Case Else
                    strTitle = "Please select a file"                                       'File Dialog
                    Set fd = Application.FileDialog(gclmsoFileDialogFilePicker)
            End Select
            
        'Invoke filedialog
            With fd
                .Title = strTitle
                .AllowMultiSelect = False
                .Show
                strObjectName = .SelectedItems(1)
            End With
            
        'Pass value to function
            GetFDObjectName = strObjectName
        
        'Tidy up
            Set fd = Nothing
            
    End Function
    

    The Final Sub()

    I took the original Sub() and made it a Private Sub() of the new main Sub(). The Main Sub() gets the Absolute Path of a file and passes it to the Private Sub(). The Main Sub() is immediately below, the Private Sub() follows the Main Sub()

    Option Compare Database
    
    Sub LoadExcelFilesToAccessTables()
         
        'Author     :   Winston Snyder
        'Date       :   4/14/2014
        'Purpose    :   Load files from folder to target tables in database
         
        'Declare variables
            Dim fso As Object
            Dim fsoFoler As Object
            Dim strFolderInputFiles As String
            Dim strAbsolutePath As String
     
        'User - choose a folder that contains files to be loaded to the database
            strFolderInputFiles = GetFDObjectName(strDialogType:="Folder")
     
        'Create a FileSystemObject (FSO)
            Set fso = GetFileSystemObject
             
        'Get an FSO folder for the input files
            Set fsoFolder = fso.GetFolder(strFolderInputFiles)
             
        'Load each file in the folder to it's respective Table in Access
            For Each fsoFile In fsoFolder.Files
                strAbsolutePath = fso.GetAbsolutePathName(fsoFile)
                Call TransferSpreadsheetRoutine(strFullFileName:=strAbsolutePath)
            Next fsoFile
             
        'Tidy up
            Set fsoFolder = Nothing
            Set fso = Nothing
     
    End Sub
    
    
    
    
    Private Sub TransferSpreadsheetRoutine(strFullFileName As String)
    
        'Arguments: Accepts 1 argument, "strFullFileName" as a string
        'Resuts   : Split full file name into path and file name segments
        '           Create table name from file name
        '           Transfer spreadsheet to target database table
    
        
        'Declare variables
            Dim strPath                     As String
            Dim strFileNameSubstring        As String
            Dim strTable                    As String
    
                
            'Get folder path from full file name
                strPath = GetSegmentsFromFullFileName(strCompleteFileName:=strFullFileName, _
                                                      strSubstringType:="Path")
                
            'Get file name substring from full file name
                strFileNameSubstring = GetSegmentsFromFullFileName(strCompleteFileName:=strFullFileName, _
                                                                   strSubstringType:="File")
                
            'Get Access Table name from the file name
                strTableName = GetTableName(strFile:=strFileNameSubstring)
                
        'Transfer spreadsheet to table
            With DoCmd
                'Turn warnings off
                    .SetWarnings False
        
                'Transfer spreadsheet
                    .TransferSpreadsheet _
                        TransferType:=acImport, _
                        TableName:=strTableName, _
                        FileName:=strPath & strFileNameSubstring, _
                        HasFieldNames:=True
        
                'Turn warnings on
                    .SetWarnings True
                    
            End With
    
    End Sub
    

    TablesUpdated

    I changed the view of the Navigation Pane in MS Access to View By Details. There are a couple of items of note:

    1. The dimTeams table was created on 11/7/2013 and modified on 4/16/2014
    2. The other 2 tables were created on 4/16/2014 and modified on 4/16/2014

    I intentionally deleted the 2 tables before spinning the process, I wanted to show you, that when you use the TransferSpreadsheet Method, if the table does not already exist, it will be created! That is pretty cool. However, I have seen instances when I use TransferSpreadsheet Method and I did not explicitly create the table and setup all the datatypes for each field – I end up with some unwanted results. So I now create all tables, fields ahead of time so I explicitly control all datatypes.

    Power Pivot

    PowerPivotImport

    I now have a great process for keeping my Dimension (dim) Tables up-to-date with any kind of frequency that I need – usually monthly after month-end close to pick up any changes in accounts, or organizational structure. I just spin my process to create my Excel files, spin the DoCmd process to import the Excel file to the appropriate dim table and refresh the Data Model in the Power Pivot window.

    PowerPivotRefresh

    Slowly Changing Dimensions (SCD)

    What I demonstrated here, is an example of a Type 2 Slowly Changing Dimension (SCD). There are 6 different SCD’s. You may read more about them here.

    If this Data Model was properly constructed, I would most likely have 3 different entries (maybe more) for the now Arizona Cardinals.

    1. The club was established in Chicago in 1898
    2. They moved to St. Louis Missouri in 1960
    3. They moved to Phoenix, Arizona in 1988

    There are many other examples along those lines – so Type 2 SCD.

    Tidy Up

    That’s it for today – lot’s to do on my Honey DoCmd List. This is a fairly long post with hopefully a little something for everyone.

    , , , , , , , ,