Beyond Excel: VBA and Database Manipulation


December 15, 2009  6:13 PM

75% Done

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker

As far as writing reports in Excel is concerned, using just what we’ve discussed up til now get’s us about 75% of where I want to take us.  The next 25% is more tedious to work through, but the advantages are worth it.

Quick Change SQL
The first advantage is simplifid SQL management.  This is achieved by listing database tables and fields/columns in an Excel table (called Fields), then using code to assemble the SQL for us.  With the field names in an Excel table, we can sit down with the user and quickly customize their report.  We can easily change the column order, include more fields, drop fields, change the column headings, change sort sequences, add formulas, add formats, and chose a field to freeze the panes on – all without coding – well – that is – without additional coding beyond the library of routines needed to support this.

Excel Formulas
Adding formulas is huge.  It plays to Excel’s unique strengths.  What if our customer wants to know what day of the week orders hit most?  That isn’t in the database.  The date is.  But to get the day of the week requires a formula, one that happily already exists in Excel.  What if our customer wants to know the aging of his receivables.  The age isn’t in the database.  But the date is.  And happily, subtracting the database date from today is a snap in Excel. 

One of the routines we will add facilitates inserting complex Excel formulas from our Fields table into our retrieved records.

SQL Formulas
I find that SQL formulas work best for making odd date fields standard.  I’ve seen Julian dates, seconds elapsed since some beginning date dates, year/month/day dates all crammed together in one numeric field, date and time stamp dates when all you want is the date, and the AS/400’s (iSeries, Power i, …)  system dates with a century flag.  Users don’t like them.  They want standard dates.  Excel doesn’t like them.  Excel’s formulas only work with standardized dates.  

One of the routines we will add facilitates inserting complex SQLformulas from our Fields table into our retrieved records.

Formats
Excel has rich formatting capabilities.  This can really improve the readability of our results.

We will add routines to apply numeric formatting, left/right/center align data, wrap data, hide columns, limit column widths, and conditionally grey out repetitive data in rows from values in our Fields Table.

Sorting
Often SQL sorts data just fine.  But there are two reasons not to use it.   First, why burden your database server with that task when your PC’s processor is dedicated to you alone?  Let Excel do it.  Second, what if the sort order you want is based on a formula result?  Excel can sort that too.

We will add routines to sort in any combination of orders and with as many columns as you have fields identified in our Fields Table.

Freezing
When working with large databases, it is important to keep the column headings always in view.  You may also want to keep some of the row keys in view as well.  Excel’s “Freeze Pane” function handles this nicely.

We will add a routine to apply freezing to any field in our Fields table.

Future Use
When we get into updating databases from Excel, (assuming your auditors allow such heresy) we will need some additional functionality from our Fields table, like:

  • Lock certain fields from changes
  • Make some fields required
  • Validate fields against tables
  • etc.

Next post will show what this table looks like, then we’ll get down to adding more routines to our library to deliver on its promise.

December 10, 2009  6:03 PM

It’s Time to Play

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker

In the last post, we integrated frmPrompt into Macro1(), but we didn’t take full advantage of what frmPrompt offers.  We limited values to just one for each parameter.  Today we are going to add the ability to filter our database using wildcards or lists.

We will be adding a new function called Build_SQL_ID.  Build_SQL_ID looks at the value from frmPrompt and determines if our user intended to:

  • Filter at all
  • Filter on just one value
  • Filter on a list
  • Filter based on a wildcarded value

I hope you can see the power this gives our customers to mine information from their data.

We will be changing the SQL statement slightly to let Build_SQL_ID add the appropriate comparison.  We’ll look at Build_SQL_ID first, then be sure to check the changed SQL statement at the end.  Add Build_SQL_ID to your module and replace the SQL statement in Macro1() with this new one.

After completing this, click your easy button to bring up frmPrompt, key in different values for customers or products, select multiple values from lists, use wildcards, or leave the fields blank alltogether.  See how it changes your pivot table and chart.  It’s time to play.  Enjoy.

Public Function Build_SQL_ID(sField As String, sValue As String, bAddQuotes As Boolean) As String
'   Build_SQL_ID: Create a field's comparison string
'                 If sValue = "*ALL" then no comparison string is desired
'                 If sValue contains a wild card then "LIKE" must be used
'                 Otherwise "IN" must be used
'   Parameters:   sField     Table's column name
'                 sValue     The value to filter results on
'                 bAddQuotes Set to True for character values
'   Example:      sSQL = "Select * " & _
'                        "From   Employees " & _
'                        "Where  Status = 'ACTIVE' " & _
'                         Build_SQL_ID("STATE", "'MN', 'VA', 'ND'")
'     Date   Init Modification
'   11/10/09 CWH  Initial Programming
    On Error GoTo ErrHandler
    Build_SQL_ID = ""
   
    If Trim(sField) > "" And Trim(sValue) > "" Then
        If bAddQuotes Then sValue = "'" & _
            Replace(Replace(sValue, "'", ""), ",", "','") & "'"
        Build_SQL_ID = _
            IIf(UCase(sValue) = "*ALL", "", _
                IIf(InStr(1, sValue, "?") > 0 Or InStr(1, sValue, "%") > 0, _
                   "  And   " & sField & " like " & sValue & " ", _
                       "  And   " & sField & " in (" & Trim(sValue) & ") " _
                    ) _
                )
    End If
ErrHandler:
  
    If Err.Number <> 0 Then MsgBox _
        "Build_SQL_ID- Error#" & Err.Number & vbCrLf & Err.Description, _
        vbCritical, "Error", Err.HelpFile, Err.HelpContext
    On Error GoTo 0
End Function

 

New SQL statement

            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") & "# " & vbCr & _
                    Build_SQL_ID("O.`Customer ID`", .pID1, False) & vbCr & _
                    Build_SQL_ID("P.`Product Code`", .pID2, True)
 


December 8, 2009  10:58 PM

Putting it all Together

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker

In the last post we finalized frmPromptfrmPrompt provides a feature rich and professional looking method for getting parameters for our customer’s reports.  Today, we’re going to ignore some of those rich features in order to ease us into integrating frmPrompt into our Macro1()

Below is our new Macro1().  The first thing you will notice is the number of parameters it sets for other forms.  This is a good thing.  By putting everything into parameters, we can essentially put all of our coding efforts into this routine and the pivot routine – and that’s it.  For many reports, we can ignore all those support routines and forms we created and focus solely on Macro1().  The parameters prompt us for what we need to change so the guess work of what needs to be done is eliminated. 

The toughest part is creating the SQLs for the ellipse buttons and our report.  The ellipse buttons require two simple SQLs each.  They are nearly identical.  They both select the same two fields (one Code/ID field and one Description/Name field).  They both use the same table.  They differ in the Where and Order by clauses, with one filtering and ordering by ID, and the other by Name.  If you’re having trouble with SQL, use MQ Query like we did earlier to prototype.

Our main SQL is relatively complex with four tables joined.  Most reports I’ve seen do not require this many.  Even so, four can easily be prototyped with MS Query.  Once we have the skeleton SQL provided by MS Query, all we need to do is string it together with our parameters from frmPrompt.  As I mentioned at the beginning, for this exercise, I have ignored some of the complexities of integrating all of the features that frmPrompt provides us.  frmPrompt allows us to select wild card values and multiple values.  With what is posted here, we can’t use those.  That will be our next posts focus.  In the mean time, try this out making sure you only select one value each for Customers and Products.

Sub Macro1()
    Dim sSQL As String
    Dim sConnect As String
        sConnect = "Driver={Microsoft Access Driver (*.mdb, *.accdb)};" & _
                   "DBQ=C:\Users\chatmaker\Documents\Northwind 2007.accdb;"
                  
    With frmPrompt
        'Set up frmPrompt's labels and textboxes
        .pDateLbl = "Ordered Dates"        'Set the prompt for dates
        .pFromVisible = True               'Enable "From Date" text box
        .pFrom = "01/01/2006"              'Set default for "From" text box
        .pToVisible = True                 'Enable "To Date" text box
        .pTo = Format(Now(), "mm/dd/yyyy") 'Set default for "To" text box
        .pID1Visible = True                'Enable ID1's label and text box
        .pID1Lbl = "Customer ID(s)"        'Set the prompt for ID1
        .pID2Visible = True                'Enable ID2's label and text box
        .pID2Lbl = "Product Code(s)"       'Set the prompt for ID2
       
        'Set up elipse button for Customers
        .pTitle1 = "Select Customers"      'Set frmSelect_Multiple's title
        .pConnect1 = sConnect              'Set connection string
        .pLblCode1 = "Code"                'Set label for the codes/ID column
        'Create SQL string to use to search for Customer Codes
        .pSQLCode1 = "Select   ID as Code, " & _
                              "Company as Name " & vbCr & _
                     "From     Customers " & vbCr & _
                     "Where    ID like '%?%' " & vbCr & _
                     "Order By ID"
        .pLblDesc1 = "Company"             'Set description/name column label

        'Create SQL string to use to search for Customer's Company Names
        .pSQLDesc1 = "Select   ID as Code, " & _
                              "Company as Name " & vbCr & _
                     "From     Customers " & vbCr & _
                     "Where    Company like '%?%' " & vbCr & _
                     "Order By Company"
       
        'Set up elipse button for Products
        .pTitle2 = "Select Products"       'Set frmSelect_Multiple's title
        .pConnect2 = sConnect              'Set connection string

        .pLblCode2 = "Code"                'Set label for codes/ID column
        'Create SQL string to use to search for Product Codes

        .pSQLCode2 = "Select   `Product Code` as Code, " & _
                              "`Product Name` as Name " & vbCr & _
                     "From     Products " & vbCr & _
                     "Where    `Product Code` like '%?%' " & vbCr & _
                     "Order By `Product Code`"
        .pLblDesc2 = "Name"                'Set description/name column label

        'Create SQL string to use to search for Product Names
        .pSQLDesc2 = "Select   `Product Code` as Code, " & _
                              "`Product Name` as Name " & vbCr & _
                     "From     Products " & vbCr & _
                     "Where    `Product Name` like '%?%' " & vbCr & _
                     "Order By `Product Name`"
                    
       .Show                               'Display the Prompt
        Do While .Visible                  'Wait on user
            DoEvents
        Loop
        If .pOK Then                       'OK button used to exit
          
            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.`Customer ID` = " & Trim(.pID1) & " " & vbCr & _
                   "  AND  P.`Product Code`= '" & Trim(.pID2) & "' " & vbCr & _
                   "  AND  O.`Order Date` Between #" & _
                           Format(.pFrom, "mm/dd/yyyy") & "# And #" & _
                           Format(.pTo, "mm/dd/yyyy") & "# "
      
            SQLLoad sSQL, sConnect, "A4", "Data", "Data"
      
            If Range("Data").Rows.Count > 1 Then Pivot_Template
           
        End If
    End With
End Sub


December 4, 2009  10:20 PM

Asking for It

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker

frmPrompt

frmPrompt

In the last two posts I provided two support forms, frmSearch_Multiple and frmDatePicker, for the form I’m going to show you now: frmPrompt (shown right).  frmPrompt asks your customers for the parameters required to extract only the data they need for their reports.  frmPrompt is very versatile and can probably handle about 90% of the requests you might receive.  But think of frmPrompt as a template because there will be times when check boxes, radio buttons, drop down lists, and other form controls are better suited for your purposes.  The nice thing is, you have all of the source code right here.  You can change frmPrompt to whatever you want.

In this version of frmPrompt, we are asking for three parameters:

  1. A date range – In this case, a range between which products were ordered.  If the user prefers selecting dates from a calendar, they just click the calendar icon button beside the date text box to bring up last posts frmDatePicker.
  2. Customer IDs – The user can narrow down orders based on who ordered them.  Assuming the user doesn’t know all codes, they can select customer codes from frmSelect_Multipleby clicking the appropriate ellipse button.
  3. Product Codes – The user can further narrow the list based on what products were ordered.  The user can select product codes from frmSelect_Multipleby clicking the appropriate ellipse button.

To recreate this version of frmPrompt, get to the VBE (Alt-F11) and create a form with these controls:

Name Type Properties
frmPrompt UserForm Caption:=“Search Prompt”
lblDate Label Caption:=”Ordered Between:”
lblID1 Label “Customer(s)”
lblID2 Label “Product Code(s)”
lblMsg Label BorderStyle:=1 – frmBorderStyleSingle
txtFrom TextBox  
txtTo TextBox   
txtID1  TextBox   
txtID2  TextBox   
cmdFrom CommandButton Width:=18
Height:=18
Picture:= (copy this picture to your library and select it) 
cmdTo CommandButton (Same as cmdFrom)
cmdID1  CommandButton Width:=18
Height:=18
Caption:=”…” 
cmdID2  CommandButton (Same as cmdID1) 
cmdExit CommandButton Caption:=”OK”, Default:=True,
TabStop:=True
cmdOK CommandButton Caption:=”Exit”, Cancel:=True,
TabStop:=True

By now you’ve noticed that I like to have forms expose properties so they can be reused without modification.  This allows me to concentrate those things I have to modify in only a very few places, and for now, that would be Macro1().  You’ll see lots of properties from frmPrompt in this code:

' Version 12/04/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 (How to use this form):
'Public Sub TestForm()
'   Dim i As Integer    'Generic Integer Variable
'   With frmPrompt 
'        .pID1Visible = True
'        .pID1Lbl = "Customers(s)"
'        If .pID1 = "" Then .pID1 = "*ALL"
'        .pConnect1 = ConnectionString
'        .pLblCode1 = "Code"
'        .pLblDesc1 = "Customer Name"
'        .pTitle1 = "Select Customer(s)"
'        .pSQLCode1 = "Select   CUCODE as CODE, CUNAME as NAME " & _
'                     "From     CUSTMAST " & _
'                     "Where    Trim(UCase(CUCODE)) Like '?%' " & _
'                     "Order by CUCODE "
'        .pSQLDesc1 = "Select   CUCODE as CODE, CUNAME as NAME " & _
'                     "From     CUSTMAST " & _
'                     "Where    Trim(UCase(CUNAME)) Like '%?%' " & _
'                     "Order by CUNAME " '
'        .pID2Visible = False
'        .pFromVisible = True
'        .pDateLbl = "Last activity >:"
'        If .pFrom = "" Then .pFrom = Format(Int(Now() - 365), "mm/dd/yy")
'        .pToVisible = False
'      .Show                        'Display the Prompt
'       Do While .Visible           'Just pass time while the form is displayed
'           DoEvents
'       Loop
'       If .pOK Then                'The OK button was used to exit
'           Debug.Print .pFrom, .pTo, .pID1, .pID2
'       End If
'   End With
'End Sub
    Dim bOK As Boolean        'OK button pressed flag
'   frmSelect_Multiple settings for ID1
    Dim sConnect1 As String   'Connection String
    Dim sTitle1   As String   'Form Title
    Dim sLblCode1 As String   'ID column label
    Dim sSQLCode1 As String   'SQL string for searching by ID
    Dim sLblDesc1 As String   'Description column label
    Dim sSQLDesc1 As String   'SQL String for searching by Description
'   frmSelect_Multiple settings for ID2
    Dim sConnect2 As String   'Connection String
    Dim sTitle2   As String   'Form Title
    Dim sLblCode2 As String   'ID column label
    Dim sSQLCode2 As String   'SQL string for searching by ID
    Dim sLblDesc2 As String   'Description column label
    Dim sSQLDesc2 As String   'SQL String for searching by Description
'   Properties
'   Dates
Public Property Let pDateLbl(sString As String)
     lblDate.Caption = sString
End Property
'   From Date
Public Property Let pFromVisible(bFlag As Boolean)
    lblDate.Visible = bFlag
    txtFrom.Visible = bFlag
    cmdFrom.Visible = bFlag
End Property
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 pToVisible(bFlag As Boolean)
    txtTo.Visible = bFlag
    cmdTo.Visible = bFlag
End Property
Public Property Let pTo(sString As String)
    txtTo.Text = sString
End Property
Public Property Get pTo() As String 
   pTo = txtTo.Text
End Property
'   ID1
Public Property Let pID1Visible(bFlag As Boolean)
    lblID1.Visible = bFlag
    txtID1.Visible = bFlag
    cmdID1.Visible = bFlag
End Property
Public Property Let pID1Lbl(sString As String)
    lblID1.Caption = sString
End Property
Public Property Let pID1(sString As String)
    txtID1.Text = sString
End Property
Public Property Get pID1() As String
    pID1 = txtID1.Text
End Property
Public Property Let pConnect1(sString As String)
    sConnect1 = sString
    cmdID1.Visible = Trim(sString) <> ""
End Property
Public Property Let pTitle1(sString As String)
    sTitle1 = sString
End Property
Public Property Let pLblCode1(sString As String)
    sLblCode1 = sString
End Property
Public Property Let pSQLCode1(sString As String)
    sSQLCode1 = sString
End Property
Public Property Let pLblDesc1(sString As String)
    sLblDesc1 = sString
End Property
Public Property Let pSQLDesc1(sString As String)
    sSQLDesc1 = sString
End Property
'   ID2
Public Property Let pID2Visible(bFlag As Boolean)
    lblID2.Visible = bFlag
    txtID2.Visible = bFlag
End Property
Public Property Let pID2Lbl(sString As String)
    lblID2.Caption = sString
End Property
Public Property Let pID2(sString As String)
    txtID2.Text = sString
End Property
Public Property Get pID2() As String
    pID2 = txtID2.Text
End Property
Public Property Let pConnect2(sString As String)
    sConnect2 = sString
    cmdID2.Visible = Trim(sString) <> ""
End Property
Public Property Let pTitle2(sString As String)
    sTitle2 = sString
End Property
Public Property Let pLblCode2(sString As String)
    sLblCode2 = sString
End Property
Public Property Let pSQLCode2(sString As String)
    sSQLCode2 = sString
End Property
Public Property Let pLblDesc2(sString As String)
    sLblDesc2 = sString
End Property
Public Property Let pSQLDesc2(sString As String)
    sSQLDesc2 = sString
End Property
'   OK button
Public Property Get pOK() As Boolean 
   pOK = bOK
End Property
 
'   Event Handlers
'   From Date Picker
Private Sub cmdFrom_Click()
    On Error GoTo ErrorHandler
        With frmDatePicker
            .Top = Me.Top + cmdFrom.Top + 20
            .Left = Me.Left + cmdFrom.Left + cmdFrom.Width + 8
            .pDate = IIf(IsDate(txtFrom), txtFrom, Format(Now(), "mm/dd/yy"))
            .Show
            Do While .Visible
                DoEvents
            Loop
            If.pOK Then txtFrom = .pDate
        End With 
ErrorHandler:
    On Error GoTo 0
End Sub
'   To Date Picker
Private Sub cmdTo_Click()
    On Error GoTo ErrorHandler
    With frmDatePicker
        .Top = Me.Top + cmdTo.Top + 20
        .Left = Me.Left + cmdTo.Left + cmdTo.Width + 8
        .pDate = IIf(IsDate(txtTo), txtTo, Format(Now(), "mm/dd/yy"))
        .Show
        Do While .Visible
            DoEvents
        Loop
        If .pOK Then txtTo = .pDate
    End With   
ErrorHandler:
    On Error GoTo 0
End Sub

'   ID1 Elipse Button
Private Sub cmdID1_Click()
   With frmSelect_Multiple
      .pConnect = sConnect1
      .pTitle = sTitle1
      .pSelections = IIf(UCase(txtID1) = "*ALL", "", txtID1)
      .pLblCode = sLblCode1
      .pSQLCode = sSQLCode1
      .pLblDesc = sLblDesc1
      .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

'   ID2 Elipse Button
Private Sub cmdID2_Click()
   WithfrmSelect_Multiple
      .pConnect = sConnect2
      .pTitle = sTitle2
      .pSelections = IIf(UCase(txtID2) = "*ALL", "", txtID1)
      .pLblCode = sLblCode2
      .pSQLCode = sSQLCode2
      .pLblDesc = sLblDesc2
      .pSQLDesc = sSQLDesc2
      .Show
       Do While .Visible
           DoEvents
       Loop
       If.pOK Then   'The OK button was used to exit
            If UCase(txtID2) = "*ALL" Then txtID2 = ""
            txtID2 = .pSelections
            txtID2.ForeColor = RGB(0, 0, 0)
            txtID2.BackColor = RGB(256, 256, 256)
       End If
   End With
End Sub

'   OK Button
Private Sub cmdOK_Click()
    Dim s As String             'Generic String
    Dim bError As Boolean 
        bError = False 
        ResetTextColor
    If txtFrom.Visible Then
        If txtFrom > "" And NotIsDate(txtFrom) Then
            SetError txtFrom, False, "Please check date"
            bError = True
        End If
    End If
    If Not bError And txtTo.Visible Then
        If txtTo > "" And Not IsDate(txtTo) Then 
            SetError txtTo, False, "Please check date"
            bError = True
        End If
    End If
    If Not bError And txtTo.Visible Then
        If DateValue(txtFrom) > DateValue(txtTo) Then 
            s = txtFrom  
            txtFrom = txtTo
            txtTo = s
            SetError txtFrom, True, ""
            SetError txtTo, True, "From & To dates swapped. Click OK."
            bError = True
        End If
    End If
    If NotbError And txtID1.Visible Then
        If(InStr(1, txtID1, "*") > 0 Or_
            InStr(1, txtID1, "?") > 0) And_
            InStr(1, txtID1, ",") > 0 Then 
            SetError txtID1, False, "Cannot mix wildcards w/multiple selections"
            bError = True
        End If
    End If
    If NotbError And txtID2.Visible Then
        If(InStr(1, txtID2, "*") > 0 Or_
            InStr(1, txtID2, "?") > 0) And_
            InStr(1, txtID2, ",") > 0 Then 
            SetError txtID2, False, "Cannot mix wildcards w/multiple selections"
            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

'   Exit Button
Private Sub cmdExit_Click()
    Me.Hide
End Sub
 
'   Activate Form
Private Sub UserForm_Activate()
    ResetTextColor
    cmdID1.Visible = sConnect1 > ""
    cmdID2.Visible = sConnect2 > ""
    Me.Left = Application.Left + Application.Width / 2 - Me.Width / 2
    bOK = False 
    lblMsg = ""
End Sub

'   Sets error communication
Private Sub SetError(ctrl As Control, bWarn As Boolean, sErrMsg As String)
    Beep
    If bWarn Then 
        ctrl.BackColor = RGB(256, 256, 0)   'Yellow
        ctrl.ForeColor = RGB(0, 0, 0)       'Black
    Else
        ctrl.BackColor = RGB(256, 0, 0)     'Red
        ctrl.ForeColor = RGB(256, 256, 0)   'Yellow
    End If 
    lblMsg.ForeColor = RGB(127, 0, 0)       'Dark Red
    lblMsg = sErrMsg
End Sub

'   Clears any error coloring
Private Sub ResetTextColor()
    txtFrom.ForeColor = RGB(0, 0, 0)
    txtFrom.BackColor = RGB(256, 256, 256)
    txtTo.ForeColor = RGB(0, 0, 0)
    txtTo.BackColor = RGB(256, 256, 256)
    txtID1.ForeColor = RGB(0, 0, 0)
    txtID1.BackColor = RGB(256, 256, 256)
    txtID2.ForeColor = RGB(0, 0, 0)
    txtID2.BackColor = RGB(256, 256, 256)
End Sub

In the next post we will integrate this form into Macro1().  See you then.


December 3, 2009  9:23 PM

Looking for a Date?

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker

Last post I introduced frmSelect_Multiple that helps users find:

  • Codes/Types by Code/Type or Description
  • Cities by Zipcode or Name
  • Accounts by Number or Description
  • Employees, Customers, or Vendors by ID/Number or Name
  • Inventory/Stock Items or Products by SKU/UPC/GTIN or Description
  • Books by ISBN or Title
  • etc., etc.

I promised to show in this post how frmSelect_Multiple integrates to frmPrompt without code changes.  I ask your forgiveness as I introduce another support form for frmPrompt instead, frmDatePicker.

Shown at right is frmDatePicker.  It is inspired heavily by an article in VBA Tips.  Why I haven’t included this long ago is only a testament to my ability to overlook the obvious sometimes.  Oh, well, better late than never.

frmDatePicker

frmDatePicker

First, get to the VBE (Alt-F11) and add the Microsoft Calendar Control using the menu path Tools > References  -or-  Tools > Additional Controls.  Add the following controls:

Name Type Properties
frmDatePicker UserForm Caption:=“Pick Date”
calCalendar Calendar ShowTitle:=False
cmdExit CommandButton Caption:=”OK”, Default:=True,
TabStop:=False
cmdOK CommandButton Caption:=”Exit”, Cancel:=True,
TabStop:=False

The command buttons should be behind the calendar control.  They need to be there to respond to the keyboard.  Remember there are still some of us around that like the keyboard (which is why I probably very inconsiderately overlooked this form for so long). 

Add this code 

'Version: 12/01/09
Option Explicit
Dim bOK As Boolean
'   Name:   frmDatePicker
'   Purpose:Display a status message under program control to the user
'     Date   Init Modification
'   12/01/09 CWH  Initial Programming
'   Example (How to use this form):
'Private Sub cmdFrom_Click()     
'    On Error GoTo ErrorHandler     
'    With frmDatePicker 
'        .Top = Me.Top + cmdFrom.Top + 20 
'        .Left = Me.Left + cmdFrom.Left + cmdFrom.Width + 8 
'        .pDate = IIf(IsDate(txtFrom), CDate(txtFrom), Int(Now())) 
'        .Show 
'        Do While .Visible 
'            DoEvents 
'        Loop 
'        If .pOK Then txtFrom = .pDate 
'    End With     
'ErrorHandler: 
'    On Error GoTo 0
'End Sub
 
'Properties
'   Date
Public Property Let pDate(dDate As Date)
    If IsDate(dDate) Then
        With calCalendar
             .Day = Day(dDate)
             .Month = Month(dDate)
             .Year = Year(dDate)
         End With
    End If
End Property
Public Property Get pDate() As Date
    With calCalendar
         pDate = DateSerial(.Year, .Month, .Day)
     End With
End Property
'   OK
Public Property Get pOK() As Boolean
    pOK = bOK
End Property
 
'   Event Handlers
Private Sub calCalendar_DblClick()
     cmdOK_Click
End Sub
Private Sub calCalendar_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    bOK = False
    Me.Hide
End Sub
Private Sub cmdExit_Click()
    bOK = False
    Me.Hide
End Sub
Private Sub cmdOK_Click()
    bOK = True
    Me.Hide
End Sub

Next post I promise most sincerely to integrate all of this into a better, frmPrompt.


November 30, 2009  5:02 PM

Searching for Codes

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker
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

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker

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

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker

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

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker

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

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker

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.


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: