Beyond Excel: VBA and Database Manipulation


November 30, 2009  5:02 PM

Searching for Codes



Posted by: Craig Hatmaker
database, development, excel, Microsoft Excel, ms query, odbc, sql, tutorial, vba
frmPrompt Dates and IDs

frmPrompt Dates and IDs

Last post we built a simple date prompt.  Eventually we want to get to a form that allows entry of codes, transaction numbers, identifiers, account numbers, etc.  See at right what that form looks like.  It is called frmPrompt.

Before we can implement frmPrompt, we need to create a “Code Search” form.  The “Code Search” form responds to the ellipse (…) buttons at right of our text input boxes for Customers, and Products.  The ellipse buttons are not needed if the list of codes is small; in-which-case, a simple drop down list box works great.  However, most codes in large databases are far too numerous to be practical in a drop down list box.  Instead, we need to offer users a way to search for codes by what the user is likely to know.  Most often, it is a name, a description, or a partial code.  The form to do that is show below.  It is called frmSelect_Multiple.

frmSelect_Multiple

frmSelect_Multiple

frmSelect_Multiple is the most complicated form in our bag of forms.  Fortunately, once created, frmSelect_Multiple won’t need changes or adaptations.  It works for just about any table that has a unique identifier and a name or description (I haven’t found one it hasn’t worked for). 

The User Experience
When our customers don’t know the code they need, they press the ellipse button on the frmPrompt and frmSelect_Multiple appears populated with the code table’s first few hundred entries.  If the user sees what they want, they can double click it, or put a check mark next to it and click OK.  If they want several codes, they can select them and press Add to Selections, and continue searching for more codes.  If they don’t see what they want right off, they can enter a partial code or a partial description (Product Name in this example) and click OK to bring up a list of codes matching the partial entries.

Creating frmSelect_Multiple
Use the VBE form tools to create a frmSelect_Multiple and add these controls to it.

Name Type Properties
frmSelect_Multiple UserForm Caption:=“Search Product(s)”
lblID Label Caption:=”Code”
lblDescription Label Caption:=”Product Name”
lblSelections Label Caption:=”Selections”
txtID txtBox TabStop:=True, TabIndex:=0
txtDescription txtBox TabStop:=True, TabIndex:=1
lstList ListBox ColumnCount:=2, ListStle:=1 – frmListStyleOption,
MultiSelect:=1 – frmMultiSelectMulti,
TabStop:=True, TabIndex:=2
txtSelections txtBox TabStop:=True, TabIndex:=3
cmdClear CommandButton Caption:=”Clear Selections”, Cancel:=True,
TabStop:=True, TabIndex:=4
cmdAdd CommandButton Caption:=”Add Selections”, Cancel:=True,
TabStop:=True, TabIndex:=5
cmdExit CommandButton Caption:=”OK”, Default:=True,
TabStop:=True, TabIndex:=6
cmdOK CommandButton Caption:=”Exit”, Cancel:=True,
TabStop:=True, TabIndex:=7
lblMessages Label BorderStyle:=1 – frmBorderStyleSingle

Add this code

'Version: 01/01/2000
Option Explicit
'   Name:   frmSelect_Multiple
'   Purpose:Help the user find something by ID (primary key) or Description
'   Notes:  Nothing in this module should require modifications to use
'     Date   Init Modification
'   01/12/06 CWH  Initial Programming
'   Example (How to use this form):
'Private Sub cmdID1_Click()
'   With frmSelect_Multiple
'      .pConnect = sConnect1
'      .pLabelID = sLabelID1
'      .pLabelDesc = sLabelDesc1
'      .pTitle = sTitle1
'      .pSelections = IIf(UCase(txtID1) = "*ALL", "", txtID1)
'      .pSQLID = sSQLID1
'      .pSQLDesc = sSQLDesc1
'      .Show
'       Do While .Visible
'           DoEvents
'       Loop
'       If .pOK Then   'The OK button was used to exit
'            If UCase(txtID1) = "*ALL" Then txtID1 = ""
'            txtID1 = .pSelections
'            txtID1.ForeColor = RGB(0, 0, 0)
'            txtID1.BackColor = RGB(256, 256, 256)
'       End If
'   End With
'End Sub
    Dim sConnect As String
    Dim sSQLID As String
    Dim sID As String
    Dim sSQLDesc As String
    Dim sDesc As String
    Dim bOK As Boolean
'   Properties
'   Title
Public Property Let pTitle(sString As String)
    Me.Caption = sString
End Property
'    ID
Public Property Let pLabelID(sString As String)
    lblID.Caption = sString
End Property
Public Property Let pDefaultID(sString As String)
    txtID.Text = sString
End Property
Public Property Let pSQLID(sString As String)
'   The String must contain a valid SQL select statement with a "?"
'   to indicate where to substitute the txtID.text
    sSQLID = sString
End Property
'   Description
Public Property Let pLabelDesc(sString As String)
    lblDescription.Caption = sString
End Property
Public Property Let pDefaultDesc(sString As String)
    txtDescription.Text = sString
End Property
Public Property Let pSQLDesc(sString As String)
'   The String must contain a valid SQL select statement with a "?"
'   to indicate where to substitute the txtDesc.text
    sSQLDesc = sString
End Property
'   Connect - ODBC connection string (Required)
Public Property Let pConnect(sString As String)
    sConnect = sString
End Property
'   Current Selections
Public Property Let pSelections(sString As String)
    txtSelections = sString
End Property
Public Property Get pSelections() As String
    pSelections = txtSelections
End Property
'   True if the OK button was clicked
Public Property Get pOK() As Boolean
    pOK = bOK
End Property
'   Event Handlers
'   Add to Selections Button
Private Sub cmdAdd_Click()
           
    Dim i As Integer
   
    For i = 0 To lstList.ListCount - 1
        If lstList.Selected(i) Then
            txtSelections.Text = txtSelections.Text & _
                IIf(Len(txtSelections) > 0, ",", "") & _
                    lstList.List(i, 0)
            lstList.Selected(i) = False
        End If
    Next i
End Sub
'   Clear Selections Button
Private Sub cmdClear_Click()
    txtSelections.Text = ""
End Sub
'   Exit Button
Private Sub cmdExit_Click() 'Exit Click
    Me.Hide
End Sub
'   OK Button
Private Sub cmdOK_Click()   'OK Click
    On Error GoTo ErrHandler:
   
    Dim i As Integer
    Dim sSQL As String
   
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
   
    Dim iTimeOut As Integer
   
    Dim errLoop As Error
   
'   Initialize variables used in this routine
    sSQL = ""
      
'   Create SQL search string if ID changed
    If txtID <> sID Then
        sID = txtID
        txtDescription = ""
        sDesc = ""
        sSQL = InsertSQLVariable(sSQLID, Trim(UCase(sID)))
        txtID.SetFocus
    End If
'   Create SQL search string if description changed
'   (this overrides ID changes)
    If txtDescription <> sDesc Then
        sDesc = txtDescription
        txtID = ""
        sID = ""
        sSQL = InsertSQLVariable(sSQLDesc, Trim(UCase(sDesc)))
        txtDescription.SetFocus
    End If
'   Search database if SQL string created
    If sSQL > "" Then
   
        Debug.Print "Start:", Time, sSQL
       
        Set cn = New ADODB.Connection
        cn.Properties("Prompt") = adPromptComplete
        cn.Open sConnect, "", ""
        Set rs = New ADODB.Recordset
       
        If iTimeOut > 0 Then
            cn.CommandTimeout = iTimeOut
        End If
   
        rs.CacheSize = 500
        rs.Open sSQL, cn, , , adAsyncFetch
        Debug.Print "End:", Time
        lstList.Clear
        If rs.EOF Then
            lblMessage = "No records found"
        Else
            lblMessage = ""
            rs.MoveFirst
            i = 0
            Do While Not rs.EOF And i < 500
                lstList.AddItem rs(0)
                lstList.List(i, 1) = IIf(IsNull(rs(1)), " ", rs(1))
                rs.MoveNext
                i = i + 1
            Loop
            lstList.Visible = True
            lstList.SetFocus
        End If
        rs.Close
        cn.Close
       
    Else    'No SQL string created
        cmdAdd_Click
'       If anything was selected, were done!
        If txtSelections > "" Then
            bOK = True
            Me.Hide
        End If
       
    End If
              
ErrHandler:
               
    If Err.Number <> 0 Then
        MsgBox "cmdOK_Click - Error#" & Err.Number & vbCrLf & Err.Description, _
            vbCritical, "Error", Err.HelpFile, Err.HelpContext
    End If
    If Not cn Is Nothing Then
        If cn.Errors.Count > 0 Then
            Dim errLoop As ADODB.Error
            For Each errLoop In cn.Errors
                MsgBox "cmdOK_Click-Error number: " & errLoop.Number & vbCr & _
                    errLoop.Description, vbCritical, "Error", _
                    errLoop.HelpFile, errLoop.HelpContext
            Next errLoop
        End If
    End If
    On Error Resume Next
    If rs.State > 0 Then rs.Close    'Close the record set
    If cn.State > 0 Then cn.Close
    On Error GoTo 0
  
End Sub
'   Double click on the list
Private Sub lstList_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    cmdAdd_Click
End Sub
'   Activate the form
Private Sub UserForm_Activate()
    Me.Left = Application.Left + Application.Width / 2 - Me.Width / 2
    bOK = False
    lstList.Visible = False
    lstList.ColumnWidths = txtID.Width & ";" & txtDescription.Width
    sID = "%"
    sDesc = ""
    lblMessage = "Wildcard characters: '_'(underscore) replaces " & _
                 "just 1 characater  '%' replaces many"
    cmdOK_Click
   
End Sub
'   Functions
'   Replaces a "?" in an SQL string with something else
Private Function InsertSQLVariable(sSQL As String, sVariable As String)
    Dim i As Integer        'Generic integer
   
    i = InStr(1, sSQL, "?")
    InsertSQLVariable = Left(sSQL, i - 1) & sVariable & _
                        Right(sSQL, Len(sSQL) - i)
End Function

In the next post we will create frmPrompt and connect frmSelect_Multiple to it.

November 23, 2009  10:08 PM

Creating a Date Prompt Form



Posted by: Craig Hatmaker
database, development, excel, Microsoft Excel, ms query, odbc, sql, vba

We’re going to replace XL’s limited InputBox function with a user form.  If you’ve never created a user form, don’t worry.  YouTube has several decent tutorials for you.  Check these out (at least the first one anyway), then come back here.

YouTube videos on how to create forms in VBA
Creating a User Form in Excel Part 1 of 3
Creating a User Form in Excel Part 2 of 3
Creating a User Form in Excel Part 3 of 3

Great, you’re back.  Now what follows may look intimidating.  But trust me, the juice is worth the squeeze since properly setup forms can be exported from the original project and imported directly into others without change.  So now that you know the basics of creating a user form, create one that looks like this with the element names and properties shown below:

frmPrompt - Dates

frmPrompt - Dates

Name Type Properties
frmPrompt    UserForm Caption:=“Search Prompt”
lblDates Label Caption:=”Ordered Dates”
lblMsg Label  
txtFrom TextBox TabStop:=True, TabIndex:=0 
txtTo TextBox TabStop:=True, TabIndex:=1
cmdExit CommandButton   Caption:=”Exit”, Cancel:=True, TabStop:=True, TabIndex:=2
cmdOK CommandButton Caption:=”OK”, Default:=True, TabStop:=True, TabIndex:=3

Next, paste the following code into the form’s code window.  Note that each form element has its properties coded/exposed.  This allows calling routines to set parameter defaults and retrieve parameter values after OK is pressed. 

'   Version 11/01/09
Option Explicit
'   Name: frmPrompt
'   Purpose: Ask the user for what they want to load
'     Date   Init Modification
'   01/12/06 CWH  Initial Programming
'   Example - see Public Sub TestForm():
'Public Sub TestForm()
'
'   With frmPrompt
'      .pDateLbl = "Dates"
'      .pFrom = Format(DateAdd("d", -Day(Now()) + 1, _
'                      DateAdd("m", -1, Now())), _
'                      "mm/dd/yyyy")                 'Start of last Month
'      .pTo = Format(DateAdd("d", -Day(Now()), _
'                    Now()), _
'                    "mm/dd/yyyy")                   'End of Last Month
'      .Show                                         'Display the Prompt
'       Do While .Visible                            'Wait on user
'           DoEvents
'       Loop
'       If .pOK Then                                 'OK button used to exit
'           Debug.Print .pFrom, .pTo
'       End If
'   End With
'
'End Sub
    Dim bOK As Boolean
'   Properties
'   Dates
Public Property Let pDateLbl(sString As String)
    lblDate.Caption = sString
End Property
'   From Date
Public Property Let pFrom(sString As String)
    txtFrom.Text = sString
End Property
Public Property Get pFrom() As String
    pFrom = txtFrom.Text
End Property
'   To Date
Public Property Let pTo(sString As String)
    txtTo.Text = sString
End Property
Public Property Get pTo() As String
    pTo = txtTo.Text
End Property
'   OK button
Public Property Get pOK() As Boolean
    pOK = bOK
End Property
'   Event Handlers
'   Exit Button
Private Sub cmdExit_Click()
    Me.Hide
End Sub
'   OK Button
Private Sub cmdOK_Click()
    Dim s As String             'Generic String
    Dim bError As Boolean
        bError = False
       
    If txtFrom > "" And Not IsDate(txtFrom) Then
        lblMsg.ForeColor = RGB(127, 0, 0)
        Beep
        lblMsg = "Please Check 'From' date"
        bError = True
    ElseIf txtTo > "" And Not IsDate(txtTo) Then
        lblMsg.ForeColor = RGB(127, 0, 0)
        Beep
        lblMsg = "Please Check 'To' date"
        bError = True
    ElseIf IsDate(txtFrom) And IsDate(txtTo) Then
        If DateValue(txtFrom) > DateValue(txtTo) Then
            s = txtFrom
            txtFrom = txtTo
            txtTo = s
            lblMsg.ForeColor = RGB(127, 64, 0)
            Beep
            lblMsg = "From & To dates swapped. Click OK to continue."
            bError = True
        End If
    End If
   
    If Not bError Then
        lblMsg.ForeColor = RGB(0, 127, 0)
        lblMsg = "Working - This can take a minute or two."
        bOK = True
        lblMsg = ""
        Me.Hide
    End If
       
End Sub
'   Activate Form
Private Sub UserForm_Activate()
    Me.Left = Application.Left + Application.Width / 2 - Me.Width / 2
    bOK = False
    lblMsg = ""   
End Sub

 

Lastly, modify our Macro1() to look like the code below.  Note the “With frmPrompt” along with the property settings that follow.  The SQL has also been modified to select based on dates (Access format).

Sub Macro1()
    Dim sSQL As String
    Dim sConnect As String
  
    With frmPrompt
        .pDateLbl = "Order Dates"                    'Label date prompt
        .pFrom = "01/01/2001"                        'Default to Jan.01 2001
        .pTo = Format(Now()), "mm/dd/yyyy")          'Default to today
        .Show                                        'Display the Prompt
        Do While .Visible                            'Wait on user 
            DoEvents
        Loop
        If .pOK Then                                 'OK button used to exit
            sConnect = "Driver={Microsoft Access Driver (*.mdb, *.accdb)};" & _
                       "DBQ=C:\Users\chatmaker\Documents\Northwind 2007.accdb;" 
            sSQL = "SELECT O.`Order ID`, O.`Customer ID`, " & vbCr & _
                   "       O.`Order Date`, C.`First Name`, " & vbCr & _
                   "       O.`Ship State/Province`, D.Quantity, " & vbCr & _
                   "       P.`Product Name` " & vbCr & _
                   "FROM   Customers C, Orders O, " & vbCr & _
                   "       `Order Details` D, Products P " & vbCr & _
                   "WHERE  O.`Customer ID` = C.ID " & vbCr & _
                   "  AND  O.`Order ID`    = D.`Order ID` " & vbCr & _
                   "  AND  D.`Product ID`  = P.ID " & vbCr & _
                   "  AND  O.`Order Date` " & _
                           "Between #" & Format(.pFrom, "mm/dd/yyyy") & _
                           "#  And  #" & Format(.pTo, "mm/dd/yyyy") & "# "
            SQLLoad sSQL, sConnect, "A4", "Data", "Data"
            Pivot_Template
        End If
    End With
End Sub

How to Copy Code from this Blog to XL

  1. Open your XL spreadsheet containing modGeneral.
  2. Get to the VBE (Alt-F11)
  3. Open modGeneral in the Code Window
  4. From this post, select and copy the code
  5. Paste into the Code Window (*see next paragraph)
  6. Make any corrections to code that didn’t paste correctly
  7. From the VBE menu navigate File > Export File…
  8. Save modGeneral and remember where you saved it.

Unfortunately, the code won’t paste 100% properly.  You will have to add carriage returns and perhaps fix a few things until your code looks exactly like what you see here.


November 18, 2009  9:13 PM

Good Form



Posted by: Craig Hatmaker
database, development, excel, Microsoft Excel, ms query, odbc, sql, vba

If we stopped with only what has been posted in this blog so far, we would have a powerful tool set to create meaningful charts and drill down pivot tables from data residing in just about any database.  It only takes a couple of minutes to replace the SQL statement in Macro1() and to set parameters in a pivot table wrapper or two, at which point, your customers can see the relationships in their data and begin to identify opportunities for improvement. 

Since starting this blog, my team’s customers have received spreadsheets that determine employee’s bonuses, identify underperforming accounts, measure staff efficiencies, respond to external customers’ requests for information, etc., etc., etc.  There’s a lot you can do with what we’ve provided here but there’s more we can do to make our delivered product follow “good form.”

We have been using VBA’s “InputBox” function to ask users which records to pull.  This works as long as there’s only one parameter and as long as your customer readily knows all values for it.  Often, neither of these two situations apply.  Often, transaction dates with employee IDs, or customer IDs, or account numbers, etc. determine which records to retrieve.  For this, we need a good form.  

frmPrompt Dates and IDs

frmPrompt Dates and IDs

Good forms improve the user’s experience and increase the power of your product by handling multiple parameters and checking those parameters before bothering the server with a meaningless request and frustrating our customers with unsatisfactory results. For the next several posts, we will be looking at two forms, and derivations of one, that address the most common prompts for parameters.

The smaller form, frmPrompt, is the initial form.  By subtracting screen elements and passing parameters, we can customize this form to handle just about any request for data without changes to code; however, occasionally I do modify this form.  In my environment, I often add a group box with radio buttons to select iSeries libraries so the same spreadsheet can be used over different companies sharing the same server.  I suspect most other environments won’t need this capability so to simplify things, I have omitted that feature.  My only reason for mentioning this is to emphasize something I pointed out on the first page of this blog – these techniques are designed for developers.  What you, the developer, brings to these techniques is critical.  Though most of the code is isolated so that changes are often not required, all of the code is provided so you can adapt it to your special requirements without hindrance.  And with that said…  

The larger form, frmSelect_Multiple, supports frmPrompt.  It responds to the ellipse buttons (. . .) and facilitates searching for ID’s, Codes, Accounts, and such.  Since creating this form many years ago, it has never needed modification of any type to accommodate any master file, or code file.  Hopefully, you’ll be as lucky.  But should you have a need, the code is there for you to change.

frmSelect_Multiple

frmSelect_Multiple

My next post will be a stripped down version of frmPrompt to get you introduced (assuming you haven’t been already) to the art of creating forms in VBA.


November 10, 2009  5:58 PM

Say Goodbye to QueryTables



Posted by: Craig Hatmaker
database, development, excel, Microsoft Excel, ms query, odbc, sql, vba

We started with the QueryTable object in order to ease into this subject.  It’s time to say farewell to QueryTable and fully embrace ADO.  I’m using ADO, not because it’s the best, but because it is compatible with everything my customers have and (I’m guessing) with 98% of all current XL installs, and because the coding for ADO is nearly identical to the older DAO and other newer database access methods available to VBA.  So as technology progresses, our code needn’t change drastically.

We are replacing the QueryTable object with a call to another function that snaps into our code.  The function looks very much like the SQLRead function from the last post.  Here it is:

Function SQLLoad(sSQL As String, _
                 sConnect As String, _
                 sRange As String, _
                 Optional sSheet As String, _
                 Optional sName As String, _
                 Optional iTimeOut As Integer, _
                 Optional bAppend As Boolean) As Boolean
'   SQLLoad:     Loads an XL Range with data from a database table/file
'   Parameters:  sSQL        SQL Select statement
'                sConnect    Connection String
'                sRange      upper left cell address (ex. "A5") to put data
'                sSheet      worksheet to receive data
'                sName       name to give the retuned data
'                iTimeout    milliseconds to wait for a result before quitting
'                bAppend     Set to true to append data to a previous result
'   Example:     bResult =  SQLLoad("Select * From QUSRSYS/QAEZDISK", _
'                                   "DRIVER={iSeries Access ODBC Driver};" & _
'                                   "SYSTEM=10.0.0.3;NAM=1;", _
'                                   "A4","Data","Data",300,False )
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming
    On Error GoTo ErrHandler
    SQLLoad = Failure           'Assume Something went wrong
    Dim cn As ADODB.Connection  'Connection Object
    Dim rs As ADODB.Recordset   'Recordset Object
   
    Dim lRows As Long           'Number of Rows in Range
    Dim lCols As Long           'Number of Columns in Range
    Dim l As Long               'Generic long variable
   
    Settings "Save"             'Save XL Settings
    Settings "Disable"          'Disable screen updates, etc.
   
 '  Print the start time and SQL string in VBA's immediate window
    Debug.Print "Start:", Time, sSQL
   
 '  Clear spreadsheet if this is not appending to existing data
    If Not bAppend Then
        If sSheet > " " Then
            Worksheets(sSheet).Activate
            If ClearAll(sSheet) Then GoTo ErrHandler
        End If
    End If
                    
'   Create Connection and Recordset Objects
    Set cn = New ADODB.Connection
    cn.Properties("Prompt") = adPromptComplete
    cn.Open sConnect, "", ""
    Set rs = New ADODB.Recordset
   
'   Restrict how long the query can run before failing
    If iTimeOut > 0 Then
        cn.CommandTimeout = iTimeOut
    End If
   
'   Get the data from the database
    rs.Open sSQL, cn
      
    With Range(sRange)
        lCols = rs.Fields.Count
'       Add column headings (if not appending)
        If Not bAppend Then
            For l = 0 To lCols - 1
                .Cells(1, l + 1) = rs(l).Name
                .Cells(1, l + 1).Font.Bold = True
            Next l
            l = 2
'       Position to end of data to append to
        Else
            lRows = Range(sName).Rows.Count - 1
        End If
'       Read Recordset and copy to XL
        While Not rs.EOF
            lRows = lRows + .Cells(lRows + 2, 1).CopyFromRecordset(rs, 10000)
            If Not rs.EOF Then lRows = lRows - 1
        Wend
'       Resize columns to fit data
        Cells.EntireColumn.AutoFit
'       Create a name for the data
        If sName > " " Then Names.Add sName, Range(.Cells(1, 1), _
            .Cells(lRows + 1, lCols))
    End With
       
 '  Set column headings to repeat at top of page on printouts
    ActiveSheet.PageSetup.PrintTitleRows = "$" & Range(sRange).Row & _
                                          ":$" & Range(sRange).Row
       
 '  Print the end time in VBA's immediate window
    Debug.Print "End:", Time
   
    SQLLoad = Success
ErrHandler:
   
    If Err.Number <> 0 Or cn.Errors.Count <> 0 Then
        SQLLoad = Failure
        If Err.Number <> 0 Then
            MsgBox "SQLLoad - Error#" & Err.Number & vbCrLf & Err.Description, _
                vbCritical, "Error", Err.HelpFile, Err.HelpContext
        Else
            Dim errLoop As ADODB.Error
            For Each errLoop In cn.Errors
                MsgBox "SQLLoad - Error number: " & errLoop.Number & vbCr & _
                    errLoop.Description, vbCritical, "Error", errLoop.HelpFile, _
                    errLoop.HelpContext
            Next errLoop
        End If
    End If
    On Error Resume Next
    If rs.State > 0 Then rs.Close   'Close Recordset
    If cn.State > 0 Then cn.Close   'Close Connection
    Settings "Restore"              'Restore XL Settings
    On Error GoTo 0
   
End Function 

 

Here is the modified MACRO1() with the QueryTable replaced.  Note that it looks similar, and cleaner.

Sub Macro1()
    Dim s As String
    Dim sSQL As String
    Dim sConnect As String
  
    s = Trim( _
             InputBox("Enter State Code:" & vbCr & vbCr & _
                 "'%' is a wildcard.  By itself it will retrieve all states. " & _
                 "'N%' will retrieve all states beginning with 'N'" & vbCr & _
                 "'%Y' will retrieve all states ending in 'Y'", _
                 "State Code Prompt", "%") _
            )
   
    If s > "" Then
        sConnect = "Driver={Microsoft Access Driver (*.mdb, *.accdb)};" & _
                   "DBQ=C:\Users\chatmaker\Documents\Northwind 2007.accdb;"
           
        sSQL = "SELECT O.`Order ID`, O.`Customer ID`, " & vbCr & _
               "       O.`Order Date`, C.`First Name`, " & vbCr  & _
               "       O.`Ship State/Province`, D.Quantity, " & vbCr & _
               "       P.`Product Name` " & vbCr & _
               "FROM   Customers C, Orders O, " & vbCr & _
               "       `Order Details` D, Products P " & vbCr & _
               "WHERE  O.`Customer ID` = C.ID " & vbCr & _
               "  AND  O.`Order ID`    = D.`Order ID` " & vbCr & _
               "  AND  D.`Product ID`  = P.ID " & vbCr & _
               "  AND  C.`State/Province` LIKE '" & s & "'"
       
        SQLLoad sSQL, sConnect, "A4", "Data", "Data"
       
        Pivot_Template       
    End If
   
End Sub

How to Copy Code from this Blog to XL

  1. Open your XL spreadsheet containing modGeneral.
  2. Get to the VBE (Alt-F11)
  3. Open modGeneral in the Code Window
  4. From this post, select and copy the code
  5. Paste into the Code Window (*see next paragraph)
  6. Make any corrections to code that didn’t paste correctly
  7. From the VBE menu navigate File > Export File…
  8. Save modGeneral and remember where you saved it.

Unfortunately, the code won’t paste 100% properly.  You will have to add carriage returns and perhaps fix a few things until your code looks exactly like what you see here.


November 7, 2009  10:35 PM

Using ADO to Read a Database



Posted by: Craig Hatmaker
database, development, excel, Microsoft Excel, ms query, odbc, sql, vba

Up till now, we’ve used XL’s QueryTable object to retrieve records from databases.  This post breaks away from the QueryTable to leverage the power of ADO.  One of the advantages of ADO is that we can create user defined functions to use directly in XL just like any normal XL function.

As before, we will use a VBA function that can be easily snapped into other code.  This function uses an SQL Statement and a Connection String to retrieve data and return it to the calling routine as a simple string.

Because we are using ADO, we need to add the “Microsoft ActiveX  Data Objects x.x Library”  reference (Where the x.x is the lowest version of the library your users are likely to have.  Some of my users still have Office 2003 which works with version 2.6).  To add a reference, load your XL spreadsheet, go to the VBE (Alt-F11), and from the menu take Tools > References.  From the “Available References” list, scroll down until you find the reference we need. Check it then click OK.  That’s all there is to it.  

Here is the code:

Function SQLRead(sSQL As String, sConnect As String, _
                 Optional iTimeOut As Integer, _
                 Optional bDisplayErrors As Boolean, _
                 Optional cn As ADODB.Connection) As String
'   SQLRead:     Returns a database result set as a string
'   Parameters:  sSQL           SQL Select statement
'                sConnect       Connection String
'                iTimeout       Milliseconds to wait for results before error
'                bDisplayErrors Set to False to surpress error displays
'                cn             Connection Object. If sent, sConnect is ignored
'                               Use this to speed up multiple reads
'   Example:     Cell(1,2) =  SQLExec(sSQL, sConnect)
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming
    On Error GoTo ErrHandler
    SQLRead = Failure    'Assume Something went wrong
    Dim cnSent As Boolean
    Dim rs As ADODB.Recordset
   
    Dim s As String
    Dim lCols As Long
    Dim l As Long
   
'   If connection object not sent, create from connection string
    cnSent = True
    If cn Is Nothing Then
        cnSent = False
        Set cn = New ADODB.Connection
        cn.Properties("Prompt") = adPromptComplete
        cn.Open sConnect, "", ""
    End If
    Set rs = New ADODB.Recordset
   
'   Restrict how long the query can run before failing
    If iTimeOut > 0 Then
        cn.CommandTimeout = iTimeOut
    End If
   
'   Get the data from the database
    rs.Open sSQL, cn
      
'   Put results into a comma delimited string
    lCols = rs.Fields.Count
    If Not rs.EOF Then
        rs.MoveFirst
        s = ""
        If Not rs.EOF Then
            For l = 0 To lCols - 1
                s = s & IIf(l > 0, ",", "") & """" & rs(l) & """"
            Next l
        End If
    End If
   
'   Return results
    SQLRead = s
   
ErrHandler:
   
    If Err.Number <> 0 Or cn.Errors.Count <> 0 Then
        SQLRead = Failure
        If Err.Number <> 0 Then
            MsgBox "SQLRead - Error#" & Err.Number & vbCrLf & Err.Description, _
                vbCritical, "Error", Err.HelpFile, Err.HelpContext
        Else
            Dim errLoop As ADODB.Error
            For Each errLoop In cn.Errors
                MsgBox "SQLRead - Error number: " & errLoop.Number & vbCr & _
                    errLoop.Description, vbCritical, "Error", _
                    errLoop.HelpFile, errLoop.HelpContext
            Next errLoop
        End If
    End If
    On Error Resume Next
    If rs.State > 0 Then rs.Close	'Close the record set
'   Close the connection object if created in this routine
    If Not cnSent Then If cn.State > 0 Then cn.Close
    On Error GoTo 0
   
End Function 

To test our function, let’s create an XL User Defined Function (UDF).  The code for our test is shown below.  After adding the code below (with the reference and the function above), go back to XL and put Customer ID “27″ in cell “A4″.  In cell “B4″, enter this formula: “=CustomerName(“A4″).  Our routine will retrieve the customer’s name and display it in cell “B4″. 

Public Function CustomerName(sID As String) As String
'   CustomerName:  Get Customer Name UDF
'   Parameters:    ID     Customer ID
'   Example:       =CustomerName("A4")
'     Date   Init Modification
'   11/10/09 CWH  Initial Programming
    On Error GoTo ErrHandler
    Dim sSQL As String
    Dim sConnect As String
    sSQL = "SELECT  C.`First Name` " & _
           "FROM    Customers C " & _
           "WHERE   C.ID = " & sID
    sConnect = "Driver={Microsoft Access Driver (*.mdb, *.accdb)};" & _
               "DBQ=C:\Users\chatmaker\Documents\Northwind 2007.accdb;"
'   NOTE: For previous versions of Access use:
'   sConnect = "Driver={Microsoft Access Driver (*.mdb)};" & _
'              "DBQ=C:\Users\chatmaker\Documents\Northwind.mdb;"
    CustomerName = Replace(SQLRead(sSQL, sConnect), """", "")
ErrHandler:
   
    If Err.Number <> 0 Then MsgBox _
        "CustomerName- Error#" & Err.Number & vbCrLf & Err.Description, _
        vbCritical, "Error", Err.HelpFile, Err.HelpContext
    On Error GoTo 0
End Function

 

How to Copy Code from this Blog to XL

  1. Open your XL spreadsheet containing modGeneral.
  2. Get to the VBE (Alt-F11)
  3. Open modGeneral in the Code Window
  4. From this post, select and copy the code
  5. Paste into the Code Window (*see next paragraph)
  6. Make any corrections to code that didn’t paste correctly
  7. From the VBE menu navigate File > Export File…
  8. Save modGeneral and remember where you saved it.

Unfortunately, the code won’t paste 100% properly.  You will have to add carriage returns and perhaps fix a few things until your code looks exactly like what you see here.


November 3, 2009  6:07 PM

Delivering a Finished Product



Posted by: Craig Hatmaker
database, development, excel, Microsoft Excel, ms query, odbc, sql, vba

Last post I introduced the wrapper for creating PivotTables and PivotCharts.  This wrapper isolates the changes you must make to add PivotTables and PivotCharts to just one routine.  By isolating these changes, your job is simplified and setting up PivotTables and Charts can easily take less than a minute.  All that’s left to do is to add one line to Macro1 to call the wrapper.  Once you add that line, all your user has to do to is click the “easy” button to retrieve their data, see it in a graph they can easily filter, and see it in a PivotTable that automatically provides “drill down” support.  Here is how Macro1 should look.  (*Note: The red line must be changed to where your Northwind database resides).

Sub Macro1()
    Dim s As String
'   Ask user for input parameters   

    s = Trim( _
             InputBox("Enter State Code:" & vbCr & vbCr & _
                 "'%' is a wildcard.  By itself it will retrieve all states. " & _
                 "'N%' will retrieve all states beginning with 'N'" & vbCr & _
                 "'%Y' will retrieve all states ending in 'Y'", _
                 "State Code Prompt", "%") _
            )
   
'   If OK was pressed then process request
    If s > "" Then
       
'       Clear the spreadsheet 
        Cells.Delete
        Cells.ClearContents
       
'       Get the data
        With ActiveSheet.ListObjects.Add( _
                SourceType:=0, _
                Source:=Array( _
                    "ODBC;" & _
                    "DSN=MS Access Database;" & _
                    "DBQ=C:\Users\chatmaker\Documents\Northwind 2007.accdb;"), _
                Destination:=Range("$A$5")).QueryTable
           
            .CommandText = Array( _
                "SELECT O.`Order ID`, O.`Customer ID`, O.`Order Date`, " & _
                       "C.`First Name`, O.`Ship State/Province`, " & _
                       "D.Quantity, P.`Product Name` " & vbCr, _
                "FROM   Customers C, Orders O, " & _
                      "`Order Details` D, Products P " & vbCr, _
                "WHERE  O.`Customer ID` = C.ID " & vbCr & _
                "  AND  O.`Order ID`    = D.`Order ID` " & _
                "  AND  D.`Product ID`  = P.ID " & _
                "  AND  C.`State/Province` LIKE '" & s & "'")
            .RowNumbers = False
            .ListObject.DisplayName = "Data_Data"
            .Refresh BackgroundQuery:=False        
        End With
               
'       Name the data range
        With Range("Data_Data")
            Names.Add "Data", _
                Range(.Cells(0, 1), .Cells(.Rows.Count, .Columns.Count))
            Range(Cells(.Row, 3), _
                  Cells(.Row + .Rows.Count, 3)).NumberFormat = "m/d/yy;@"
        End With
       
'       Add a PivotTable and PivotChart
        Pivot_Template
       
    End If
   
End Sub
Here is a graphic way of looking at the process.
 
  1. The user clicks the “easy” button which invokes Macro1()
  2. Macro1() gets the user input and retrieves data from the database
  3. The data is sent to the XL spreadsheet in tab Data
  4. Macro1 calls Pvt_Template
  5. Pvt_Template sets the PivotTable values and calls Setup_Pivot
  6. Setup_Pivot creates the PivotTable in tab pvtTemplate and returns control to Pvt_Template
  7. Pvt_Template calls Setup_PivotChart 
  8. Setup_PivotChart creates the PivotChart in tab chtTemplate .  Control passes up the stack to Macro1() which ends
Basic Process

Basic Process


October 31, 2009  10:05 AM

Wrapping things up



Posted by: Craig Hatmaker
database, development, excel, Microsoft Excel, ms query, odbc, sql, vba

Today I’m introducing a “wrapper” for our Pivot Table and Pivot Chart routines.  The wrapper isolates setting unique parameters from the main routine that extracts data.   Though the routine looks lengthy, it contains no logic, only parameters and instructions on how to modify it .  The instructions can be removed and not all of the parameters are required.

In this example, we create a PivotTable and chart results for the top 20 selling products with quantities broken out by state as shown in http://itknowledgeexchange.techtarget.com/beyond-excel/pivots-and-charts/

PivotTable

PivotTable
Function Pivot_Template() As Boolean
'   Pivot_Example:  Sample Pivot Table and Pivot Chart wrapper
'   Parameters:     None 
'   Instructions:   Copy this,
'                   Change all instances of "Pivot_Template" to your routine's name
'                   Modify constants
'                   Increase dimensions of arrays if needed to accomodate more than
'                       1 row, column, etc
'                   Set variable values
'                   Delete these instructions from your routine 
'   Example:        Pivot_Template
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming    
    On Error GoTo ErrHandler                  
    Pivot_Template = Failure                  'Assume the Worst
'   NOTE TO PGMR: Modify these constants' values
    Const sWorksheet = "pvtTemplate"          'Name for the PivotTable & Worksheet
    Const sDataRange = "Data"                 'Named range containing raw data
    Const sTitle = "Top 20 Products by State" 'PivotTable's title
    Const sChartType = xlColumnStacked        'Chart type to create (Optional)
'   NOTE TO PGMR: End modification to constants' values       
'   NOTE TO PGMR: Modify array dimensions (usually not required)
'                 0 = the first element so a dimension of 1 means 2 elements
'                 Changes are required ONLY if you want MORE than 1 element
    Dim sPageFields(0) As String              '0=# of Page Fields   (Optional)
    Dim sRowFields(0) As String               '0=# of Row Fields    (Required)
    Dim sColumnFields(0) As String            '0=# of Column Fields (Recommended)
    Dim sDataFields(0, 2) As String           '0=# of Data Field    (Required)
    Dim sMaxFields(0, 2) As String            '0=# of Restrictions  (Optional)
    Dim sSortFields(0, 2) As String           '0=# of Sort fields   (Optional)
'   NOTE TO PGMR: End modifications to array dimensions 
'   NOTE TO PGMR: Set parameter values. Set to "" for optional parameters you
'                 don't want or delete the parameter line from this routine
    sPageFields(0) = "Customer ID"            'Allow filtering entire pivot on this
    sRowFields(0) = "Product Name"            'This field goes down the side
    sColumnFields(0) = "Ship State/Province"  'This field goes across the top
    sDataFields(0, 0) = "Quantity"            'This field goes in the body
    sDataFields(0, 1) = "SUM"                     'Calculation performed
    sDataFields(0, 2) = "SUM Quantity"            'Name for the calculated result
    sMaxFields(0, 0) = "Product Name"         'This field is restricted
    sMaxFields(0, 1) = 20                         'To the top n values
    sMaxFields(0, 2) = "SUM Quantity"             'based on this field's value
    sSortFields(0, 0) = "Product Name"        'This field is sorted
    sSortFields(0, 1) = "Descending"              'in Ascending/Descending order
    sSortFields(0, 2) = "SUM Quantity"            'based on this field's value
'   NOTE TO PGMR: End modification to parameter values 
'   Create the Pivot Table
    Setup_Pivot sWorksheet, sDataRange, sTitle, _
                sPageFields(), sRowFields(), sColumnFields(), sDataFields(), _
                sSortFields(), sMaxFields()
'   Create a chart based on the pivot table (Optional)
    Setup_PivotChart Replace(sWorksheet, "pvt", "cht", 1, 1), _
                             sWorksheet, sChartType, sTitle
    Pivot_Template = Success                  'Successful finish
ErrHandler:
        If Err.Number <> 0 Then MsgBox _
            "Pivot_Template - Error#" & Err.Number & vbCrLf & Err.Description, _
            vbCritical, "Error", Err.HelpFile, Err.HelpContext
        On Error GoTo 0
End Function
Chart

Chart

How to Copy Code from this Blog to XL

  1. Open your XL spreadsheet containing modGeneral.
  2. Get to the VBE (Alt-F11)
  3. Open modGeneral in the Code Window
  4. From this post, select and copy the code
  5. Paste into the Code Window (*see next paragraph)
  6. Make any corrections to code that didn’t paste correctly
  7. From the VBE menu navigate File > Export File…
  8. Save modGeneral and remember where you saved it.

Unfortunately, the code won’t paste 100% properly.  You will have to add carriage returns and perhaps fix a few things until your code looks exactly like what you see here.


October 29, 2009  4:26 PM

Building a Library of Routines – Setup_PivotChart



Posted by: Craig Hatmaker
database, development, excel, Microsoft Excel, ms query, odbc, sql, vba

In our last post we added a function that creates Pivot Tables.  Pivot Tables are fantastic for summarizing data and automatically adding “drill down” functionality.  But people usually like to see things graphically.  The creators of XL realized this and provide functions for graphing Pivot Table results.  That’s what this next function does.  It’s purpose is to reduce the many Pivot Chart properties and methods down to just one function and as few parameters as possible to create meangingful and dynamic representations of your data that your customers can change simply by changing filters in the drop downs automatically provided.

Copy this to your modGeneral as before.  In my next post I will show you how to ”snap” these routines into our Northwind data extract to create impactful graphs and dynamic drill downs. 

Function Setup_PivotChart(sChartSheet As String, sWorksheet As String, _
                          lChartType As XlChartType, sTitle As String) As Boolean
'   Setup_PivotChart:Set up a Pivot Table Chart
'   Parameters:
'       sChartSheet  - The chartsheet to be created to contain the chart
'       sWorkSheet   - The worksheet name where the Pivot Table data is
'       sChartType   - The type of chart to created
'   Example:    Setup_PivotChart "chtHrs", "pvtHrs", "BarClustered"
'     Date   Init Modification
'   01/12/06 CWH  Initial Programming
'   05/15/09 CWH  Changed sChartType to lChartType to add flexibility
    On Error GoTo ErrHandler            '
    Setup_PivotChart = Failure          'Assume the Worst
               
    Settings "Save"
    Settings "Disable"
   
'   Dim Statements
    Dim i As Integer
    Dim n As Integer
   
'   Create Chart
    Worksheets(sWorksheet).Activate
    If Not ChartExists(sChartSheet) Then
        Charts.Add
        Charts(ActiveChart.Name).Name = sChartSheet
    End If
   
    Charts(sChartSheet).Activate
    ActiveChart.SetSourceData Source:=Sheets(sWorksheet). _
        Range(Sheets(sWorksheet).PivotTables(1).RowRange.Address)
    ActiveChart.Location WHERE:=xlLocationAsNewSheet
    
'   Plot Area Formatting
    ActiveChart.PlotArea.Fill.OneColorGradient _
        Style:=msoGradientDiagonalUp, Variant:=2, Degree:=1
    ActiveChart.PlotArea.Fill.ForeColor.SchemeColor = 36
   
    ActiveChart.ChartType = lChartType
    'Chart Types - From http://msdn.microsoft.com/en-us/library/bb241008.aspx
    'Name Value Description
    'xl3DArea -4098 3D Area.
    'xl3DAreaStacked 78 3D Stacked Area.
    'xl3DAreaStacked100 79 100% Stacked Area.
    'xl3DBarClustered 60 3D Clustered Bar.
    'xl3DBarStacked 61 3D Stacked Bar.
    'xl3DBarStacked100 62 3D 100% Stacked Bar.
    'xl3DColumn -4100 3D Column.
    'xl3DColumnClustered 54 3D Clustered Column.
    'xl3DColumnStacked 55 3D Stacked Column.
    'xl3DColumnStacked100 56 3D 100% Stacked Column.
    'xl3DLine -4101 3D Line.
    'xl3DPie -4102 3D Pie.
    'xl3DPieExploded 70 Exploded 3D Pie.
    'xlArea 1 Area
    'xlAreaStacked 76 Stacked Area.
    'xlAreaStacked100 77 100% Stacked Area.
    'xlBarClustered 57 Clustered Bar.
    'xlBarOfPie 71 Bar of Pie.
    'xlBarStacked 58 Stacked Bar.
    'xlBarStacked100 59 100% Stacked Bar.
    'xlBubble 15 Bubble.
    'xlBubble3DEffect 87 Bubble with 3D effects.
    'xlColumnClustered 51 Clustered Column.
    'xlColumnStacked 52 Stacked Column.
    'xlColumnStacked100 53 100% Stacked Column.
    'xlConeBarClustered 102 Clustered Cone Bar.
    'xlConeBarStacked 103 Stacked Cone Bar.
    'xlConeBarStacked100 104 100% Stacked Cone Bar.
    'xlConeCol 105 3D Cone Column.
    'xlConeColClustered 99 Clustered Cone Column.
    'xlConeColStacked 100 Stacked Cone Column.
    'xlConeColStacked100 101 100% Stacked Cone Column.
    'xlCylinderBarClustered 95 Clustered Cylinder Bar.
    'xlCylinderBarStacked 96 Stacked Cylinder Bar.
    'xlCylinderBarStacked100 97 100% Stacked Cylinder Bar.
    'xlCylinderCol 98 3D Cylinder Column.
    'xlCylinderColClustered 92 Clustered Cone Column.
    'xlCylinderColStacked 93 Stacked Cone Column.
    'xlCylinderColStacked100 94 100% Stacked Cylinder Column.
    'xlDoughnut -4120 Doughnut.
    'xlDoughnutExploded 80 Exploded Doughnut.
    'xlLine 4 Line.
    'xlLineMarkers 65 Line with Markers.
    'xlLineMarkersStacked 66 Stacked Line with Markers.
    'xlLineMarkersStacked100 67 100% Stacked Line with Markers.
    'xlLineStacked 63 Stacked Line.
    'xlLineStacked100 64 100% Stacked Line.
    'xlPie 5 Pie.
    'xlPieExploded 69 Exploded Pie.
    'xlPieOfPie 68 Pie of Pie.
    'xlPyramidBarClustered 109 Clustered Pyramid Bar.
    'xlPyramidBarStacked 110 Stacked Pyramid Bar.
    'xlPyramidBarStacked100 111 100% Stacked Pyramid Bar.
    'xlPyramidCol 112 3D Pyramid Column.
    'xlPyramidColClustered 106 Clustered Pyramid Column.
    'xlPyramidColStacked 107 Stacked Pyramid Column.
    'xlPyramidColStacked100 108 100% Stacked Pyramid Column.
    'xlRadar -4151 Radar.
    'xlRadarFilled 82 Filled Radar.
    'xlRadarMarkers 81 Radar with Data Markers.
    'xlStockHLC 88 High-Low-Close.
    'xlStockOHLC 89 Open-High-Low-Close.
    'xlStockVHLC 90 Volume-High-Low-Close.
    'xlStockVOHLC 91 Volume-Open-High-Low-Close.
    'xlSurface 83 3D Surface.
    'xlSurfaceTopView 85 Surface (Top View).
    'xlSurfaceTopViewWireframe 86 Surface (Top View wireframe).
    'xlSurfaceWireframe 84 3D Surface (wireframe).
    'xlXYScatter -4169 Scatter.
    'xlXYScatterLines 74 Scatter with Lines.
    'xlXYScatterLinesNoMarkers 75 Scatter with Lines and No Data Markers.
    'xlXYScatterSmooth 72 Scatter with Smoothed Lines.
    'xlXYScatterSmoothNoMarkers 73 Scatter with Smoothed Lines and No Data Markers.
    
'   Series Formatting - Choose Variant 1 for Columns and Area, 2 for Bars
    For i = 1 To ActiveChart.SeriesCollection.Count
        If lChartType = xlPie Or lChartType = xl3DPie _
           Or lChartType = xl3DPieExploded Then
            On Error Resume Next
            For n = 1 To ActiveChart.SeriesCollection(i).Points.Count
                ActiveChart.SeriesCollection(i).Points(n).Fill.ForeColor. _
                    SchemeColor = _
                    Choose((n Mod 10) + 1, 2, 5, 13, 3, 6, 4, 50, 11, 18, 9)
                ActiveChart.ApplyDataLabels
                ActiveChart.SeriesCollection(i).DataLabels.Font.Bold = True
                ActiveChart.SeriesCollection(i).DataLabels.Font.Color = _
                    RGB(255, 255, 255)
                ActiveChart.SeriesCollection(i).DataLabels.Font.Size = 12
                ActiveChart.SeriesCollection(i).DataLabels.NumberFormat = _
                    "#,###.00_);[Red](#,###.00)"
            Next n
            On Error GoTo ErrHandler
        Else
            ActiveChart.SeriesCollection(i).Fill.ForeColor.SchemeColor = _
                Choose((i Mod 10) + 1, 2, 5, 13, 3, 6, 4, 50, 11, 18, 9)
        End If
    Next i
       
    With Charts(sChartSheet)
        .HasTitle = True
        .ChartTitle.Text = sTitle
    End With
   
    Setup_PivotChart = Success           'Successful finish
ErrHandler:
   
    If Err.Number <> 0 Then MsgBox _
        "Setup_PivotChart - Error#" & Err.Number & vbCrLf & Err.Description, _
        vbCritical, "Error", Err.HelpFile, Err.HelpContext
    Settings "Restore"
    On Error GoTo 0
End Function

How to Copy Code from this Blog to XL

  1. Open your XL spreadsheet containing modGeneral.
  2. Get to the VBE (Alt-F11)
  3. Open modGeneral in the Code Window
  4. From this post, select and copy the code
  5. Paste into the Code Window (*see next paragraph)
  6. Make any corrections to code that didn’t paste correctly
  7. From the VBE menu navigate File > Export File…
  8. Save modGeneral and remember where you saved it.

Unfortunately, the code won’t paste 100% properly.  You will have to add carriage returns and perhaps fix a few things until your code looks exactly like what you see here.


October 28, 2009  6:43 PM

Building a Library of Routines – Setup_Pivot



Posted by: Craig Hatmaker
database, development, excel, Microsoft Excel, ms query, odbc, sql, vba

This next function is the heart and soul of creating Pivot Tables.  It’s purpose is to reduce the many Pivot Table properties and methods down to just one function and as few meaningful parameters as possible to create every Pivot Table my customers have every asked for.  Hopefully, your customers aren’t any more demanding.

Copy this to your modGeneral as before.  We will add one more routine for creating Pivot Charts, and then I will show you how to ”snap” these routines into our Northwind data extract to create impactful graphs and dynamic drill downs. 

Function Setup_Pivot(sWorksheet As String, sDataRange As String, _
                     sTitle As String, sPageFields() As String, _
                     sRowFields() As String, sColumnFields() As String, _
                     sDataFields() As String, sSortFields() As String, _
                     sMaxFields() As String) As Boolean
'   Setup_Pivot:    Set up a Pivot Table Worksheet and Pivot Table
'   Parameters:    
'       sWorkSheet      - The worksheet name where the Pivot Table will be placed
'                         and the Pivot Table name.
'       sDataRange      - The data range (raw data/database extract)
'       sTitle          - A Title to put above the pivot table
'       sRowFields(#)   - Column headers in the data range that will appear
'                         down the left of the pivot table
'       sColumnFields(#)- Column headers in the data range that will appear
'                         across the top of the pivot table
'       sDataFields(#,2)
'                   #,0 = Column headers (field name) in the data range that
'                         will be in the body of the pivot table
'                   #,1 = Operation to be performed on the data (sum,count,etc.)
'                   #,2 = Caption to use for the resulting data field
'       sSortFields(#,2)
'                   #,0 = Row or Column field to sort
'                   #,1 = Ascending or Descending order
'                   #,2 = Data field to use to sort by
'       MaxFields(#,2)
'                   #,0 = Row or Column field to restrict
'                   #,1 = Max Number of entries to display
'                   #,2 = Data field to restrict by
'   Example:
'       Setup_Pivot sWorkSheet, sDataRange, sTitle, _
'                   sPageFields(), sRowFields(), sColumnFields(), sDataFields(), _
'                   sSortFields(), sMaxFields()
'     Date   Init Modification
'   01/12/06 CWH  Initial Programming Copyright 2009 Craig Hatmaker
   
    On Error GoTo ErrHandler            '
    Setup_Pivot = Failure               'Assume the Worst
               
    Settings "Save"                     'Save current settings
    Settings "Disable"                  'Disable events, updating, calculations
   
'   Dim Statements
    Dim i As Integer
       
'   Check for the Pivot Table Worksheet and create it if it doesn't exist
    If Not WorkSheetExists(sWorksheet) Then
        Sheets.Add
        Sheets(ActiveSheet.Name).Name = sWorksheet
    Else
        Worksheets(sWorksheet).Activate
        Cells.Select
        Selection.Clear
    End If
    If PivotTableExists(sWorksheet, sWorksheet) Then
'       Just Refresh the Pivot Table if it already exists
        Worksheets(sWorksheet).PivotTables(sWorksheet).RefreshTable
    Else
'        Create the Pivot Table if it doesnt' exist
         ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
                                        SourceData:=sDataRange).CreatePivotTable _
                                        TableDestination:=Range("A4"), _
                                        TableName:=sWorksheet
         With ActiveSheet.PivotTables(sWorksheet)
            .SmallGrid = False
           
'           Add Pivot Table Page Field   
            For i = 0 To UBound(sPageFields())
                If sPageFields(i) <= "" Then Exit For
                With .PivotFields(sPageFields(i))
                   .Orientation = xlPageField
                   .Subtotals = Array( _
                     False, False, False, False, False, False, _
                     False, False, False, False, False, False)
                End With
            Next i
'           Add Pivot Table Row Fields   
            For i = 0 To UBound(sRowFields())
                If sRowFields(i) <= "" Then Exit For
                With .PivotFields(sRowFields(i))
                   .Orientation = xlRowField
                   .Subtotals = Array( _
                     False, False, False, False, False, False, _
                     False, False, False, False, False, False)
                End With
            Next i
'           Add Pivot Table Column Fields   
            For i = 0 To UBound(sColumnFields())
                If sColumnFields(i) <= "" Then Exit For
                With .PivotFields(sColumnFields(i))
                   .Orientation = xlColumnField
                   .Subtotals = Array( _
                     False, False, False, False, False, False, _
                     False, False, False, False, False, False)
                End With
            Next i
'           Add Pivot Table Data Fields, Function & Format   
            For i = 0 To UBound(sDataFields(), 1)
                If sDataFields(i, 0) <= "" Then Exit For
                With .PivotFields(sDataFields(i, 0))
                    .Orientation = xlDataField
                    If sDataFields(i, 1) <= "" Then sDataFields(i, 1) = "Count"
                    Select Case UCase(sDataFields(i, 1))
                        Case Is = "SUM"
                            .Function = xlSum
                        Case Is = "AVERAGE"
                            .Function = xlAverage
                        Case Is = "MAX"
                            .Function = xlMax
                        Case Is = "MIN"
                            .Function = xlMin
                        Case Is = "COUNTNUMS"
                            .Function = xlCountNums
                        Case Is = "PRODUCT"
                            .Function = xlProduct
                        Case Is = "STDEVP"
                            .Function = xlStDevP
                        Case Else
                            .Function = xlCount
                    End Select
                    .NumberFormat = "#,###.00_);[Red](#,###.00)"
                    If sDataFields(i, 2) <= "" Then sDataFields(i, 2) = _
                       sDataFields(i, 1) & " of " & sDataFields(i, 0)
                    .Caption = sDataFields(i, 2)
                End With
            Next i
'           Sort columns and rows   
            For i = 0 To UBound(sSortFields(), 1)
                If sSortFields(i, 0) <= "" Then Exit For
                If sSortFields(i, 1) = "Descending" Then
                    .PivotFields(sSortFields(i, 0)).AutoSort _
                    xlDescending, sSortFields(i, 2)
                Else
                    .PivotFields(sSortFields(i, 0)).AutoSort _
                    xlAscending, sSortFields(i, 2)
                End If
            Next i
'           Restrict to top/bottom entries   
            For i = 0 To UBound(sMaxFields(), 1)
                If sMaxFields(i, 0) <= "" Then Exit For
                If sMaxFields(i, 1) > 0 Then
                    .PivotFields(sMaxFields(i, 0)).AutoShow _
                    xlAutomatic, xlTop, Val(sMaxFields(i, 1)), sMaxFields(i, 2)
                Else
                    .PivotFields(sMaxFields(i, 0)).AutoShow _
                    xlAutomatic, xlBottom, Val(sMaxFields(i, 1)) * -1, _
                        sMaxFields(i, 2)
                End If
            Next i
        End With
 '      Orient datafields in columns         
        If UBound(sDataFields(), 1) > 0 Then
            With ActiveSheet.PivotTables(sWorksheet).DataPivotField
                .Orientation = xlColumnField
                .Position = 1
            End With
        End If
'       Freeze panes on row and column titles                  
        Range(ActiveSheet.PivotTables(sWorksheet).DataBodyRange.Address). _
            Cells(1, 1).Select
        ActiveWindow.FreezePanes = True
   
    End If
'   Add Worksheet Title   
    With Worksheets(sWorksheet)
        .Rows("1:1").MergeCells = False
        Range(.Cells(1, 1), .Cells(1, .PivotTables(sWorksheet).TableRange1. _
            Columns.Count)).Merge
        .Cells(1, 1) = sTitle
        .Cells(1, 1).Font.Bold = True
        .Cells(1, 1).HorizontalAlignment = xlHAlignLeft
    End With
       
    Setup_Pivot = Success               'Successful finish
ErrHandler:
   
    If Err.Number <> 0 Then MsgBox _
        "Setup_Pivot - Error#" & Err.Number & vbCrLf & Err.Description, _
        vbCritical, "Error", Err.HelpFile, Err.HelpContext
    Settings "Restore"                  'Restore active window & settings
    On Error GoTo 0
End Function
 

How to Copy Code from this Blog to XL

  1. Open your XL spreadsheet containing modGeneral.
  2. Get to the VBE (Alt-F11)
  3. Open modGeneral in the Code Window
  4. From this post, select and copy the code
  5. Paste into the Code Window (*see next paragraph)
  6. Make any corrections to code that didn’t paste correctly
  7. From the VBE menu navigate File > Export File…
  8. Save modGeneral and remember where you saved it.

Unfortunately, the code won’t paste 100% properly.  You will have to add carriage returns and perhaps fix a few things until your code looks exactly like what you see here.

 

 


October 23, 2009  4:45 PM

Building a Library of Routines – Settings



Posted by: Craig Hatmaker
database, development, excel, Microsoft Excel, ms query, odbc, sql, vba

Last post we added some small routines that tell us if various things exist so we can avoid trying to recreate what’s already there.  That avoids errors and speeds things along.  Another speed enhancer for just about any VBA routine is to shut off screen updating and calculations.  And if you ever create a routine that handles worksheet events (and I do), disabling those events while you make changes to worksheets prevents infinite loops and other problems.

The Settings routine handles turning those things off and back on.  Specifically, it is intended to:

  1. Save the current ActiveSheet, ScreenUpdating, EnableEvents, and Calculation properties
  2. Disable them before processing begins
  3. Restore them after processing ends

Three values alert Settings to which of those three functions it’s supposed to perform.  Those values are: “Save”, “Disable”, and “Restore”.  There are two other values Settings responds to.  They are: “Clear” and “Debug” which are intended to facilitate development and debugging.  “Clear” removes any saved settings.  “Debug” displays the current settings in the Immediate Window.

I like to call “Settings” from button handlers, other event handlers, and routines that could potentially be long running and make changes to the screen.  

Below is the code.  To copy this routine:

  1. Get to the VBE (Alt-F11)
  2. From the VBE menu navigate File > Import File…
  3. Load modGeneral (see previous post) 
  4. Select and copy the code below
  5. Paste into the Code Window  *
  6. Make any corrections to code that didn’t paste correctly
  7. From the VBE menu navigate File > Export File…
  8. Save modGeneral

* Unfortunately, the code won’t paste 100% properly.  You will have to add carriage returns and perhaps fix a few things until your code looks exactly like what you see here.  If someone knows a better method, please let me know so I can improve this blog.  Thanks.

Next Post: Setup_Pivot – a function for creating Pivot Tables from code.

 

Function Settings(sMode As String) As Boolean
'   Settings:       Saves, sets, and restores current application settings
'   Parameters:     sMode - "Save", "Restore", "Clear", "Disable", "Debug"
'   Example:        bResult = Settings("Disable")
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming Copyright 2009 Craig Hatmaker
    On Error GoTo ErrHandler
    Settings = Failure                  'Assume the worst
   
    Static Setting(999, 4) As Variant  'Limit to 1,000 settings, prevent loops
    Static iLevel As Integer
    Select Case UCase(Trim(sMode))
        Case Is = "SAVE"
            Setting(iLevel, 0) = ActiveSheet.Type
            Setting(iLevel, 1) = ActiveSheet.Name
            Setting(iLevel, 2) = Application.EnableEvents
            Setting(iLevel, 3) = Application.ScreenUpdating
            Setting(iLevel, 4) = Application.Calculation
            iLevel = iLevel + 1
       
        Case Is = "RESTORE"
            If iLevel > 0 Then
                iLevel = iLevel - 1
                If Setting(iLevel, 0) = -4167 Then
                    Worksheets(Setting(iLevel, 1)).Activate
                Else
                    Charts(Setting(iLevel, 1)).Activate
                End If
                Application.EnableEvents = Setting(iLevel, 2)
                Application.ScreenUpdating = Setting(iLevel, 3)
                Application.Calculation = Setting(iLevel, 4)
            End If
      
        Case Is = "CLEAR"
            iLevel = 0
            Application.EnableEvents = True
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
           
        Case Is = "DISABLE"
            Application.EnableEvents = False
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
           
        Case Is = "DEBUG"
            Debug.Print iLevel, _
            Setting(iLevel, 0), _
            Setting(iLevel, 1), _
            Setting(iLevel, 2), _
            Setting(iLevel, 3), _
            Setting(iLevel, 4), _
   
    End Select
    Settings = Success           'Normal end - no errors
ErrHandler:
   
    If Err.Number <> 0 Then MsgBox _
        "Settings - Error#" & Err.Number & vbCrLf & Err.Description, _
        vbCritical, "Error", Err.HelpFile, Err.HelpContext
    On Error GoTo 0
End Function


Forgot Password

No problem! Submit your e-mail address below. We'll send you an e-mail containing your password.

Your password has been sent to: