Beyond Excel: VBA and Database Manipulation


June 2, 2010  9:27 PM

Check Entry – Table Lookup

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker
You are here (Click to enlarge)

You are here (Click to enlarge)

One of the most common data validations methods is simple confirmation that a value exists in another table.  If the data is in an Excel range, then VLOOKUP might be just what you want.  Then again, it might not.  Suppose you want a simple spreadsheet in which you log your time against projects assigned to you.   Naturally, the data validation routine should check to make sure you only enter project IDs assigned to you and no-one else.  That is a requirement VLOOKUP can’t handle very well.

As a result I created a routine that can check just one key like VLOOKUP, or two or three.  Actually, I created two routines.  This is a case of program evolution.  My first routine used column numbers to identify columns to search instead of column headers.  Column headers are much easier to understand for us humans.  So as things went on, I decided to wrap the first routine in a routine that translated column headers into column numbers before calling the original routine. 

Here is yet another opportunity for you to start afresh and eject some of the baggage I’m keeping to maintain compatibility with spreadsheets I’ve produced over the years.  Feel free to rewrite these routines into just one.  Just make sure to maintain the integrity of the inputs and outputs.

This is the wrapper routine.  Keep this function name and parameters intact.  Merge the second into this if you feel energetic.

Public Function Table_Lookup_by_Name( _
            sTable As String, sResult_Col As String, _
            sSearch_Col1 As String, vKey1 As Variant, _
            Optional sSearch_Col2 As String, Optional vKey2 As Variant, _
            Optional sSearch_Col3 As String, Optional vKey3 As Variant _
            ) As Variant
   
'   Description:Wrapper for Table_Lookup
'   Parameters: sTable          Range name with keys and values
'               sResult_Col     Header of column containing result
'               sSearch_Col1    Header of first column to search
'                               NOTE: To speed things up, use the column
'                                     that is most likely to be unique
'               vKey1           Value to search for in sSearch_Column1
'               sSearch_Col2    Header of second column to search
'               vKey2           Value to search for in sSearch_Column2
'               sSearch_Col3    Header of second column to search
'               vKey3           Value to search for in sSearch_Column3
'   Example:    sAccess = Table_Lookup_By_Name("Security", "Authorized", _
'                                               "User", Cells(2,1), _
'                                               "Application", Cells(2,3))
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming
    On Error GoTo ErrHandler
    Table_Lookup_by_Name = Null  'Assume not found
    Dim rngTable As Range
    Dim lResult_Col As Long
    Dim lSearch_Col1 As Long
    Dim lSearch_Col2 As Long
    Dim lSearch_Col3 As Long
   
    Set rngTable = Range(sTable)
    lResult_Col = FieldColumn(sResult_Col, sTable)
    lSearch_Col1 = FieldColumn(sSearch_Col1, sTable)
    lSearch_Col2 = FieldColumn(sSearch_Col2, sTable)
    lSearch_Col3 = FieldColumn(sSearch_Col3, sTable)
   
    If lSearch_Col1 > 0 And lResult_Col > 0 Then _
        Table_Lookup_by_Name = Table_Lookup(rngTable, lResult_Col, _
                                            lSearch_Col1, vKey1, _
                                            lSearch_Col2, vKey2, _
                                            lSearch_Col3, vKey3)
                                           
ErrHandler:
   
    If Err.Number <> 0 Then MsgBox _
        "Table_Lookup_by_Name - Error#" & Err.Number & vbCrLf & _
        Err.Description, vbCritical, "Error", Err.HelpFile, Err.HelpContext
    On Error GoTo 0
End Function
 
Public Function Table_Lookup( _
                    rngTable As Range, lResult_Col As Long, _
                    lSearch_Col1 As Long, vKey1 As Variant, _
                    Optional lSearch_Col2 As Long, Optional vKey2 As Variant, _
                    Optional lSearch_Col3 As Long, Optional vKey3 As Variant _
                    ) As Variant
'   Description:Use up to 3 search criteria to find results in a table
'   Parameters: rngTable        Range name with keys and values
'               lResult_Col     Relative column# where result should be
'               lSearch_Col1    First column# to search
'                               NOTE: To speed things up, use the column
'                                     that is most likely to be unique
'               vKey1           Key to search for in lSearch_Column1
'               lSearch_Col2    Second column# to search
'               vKey2           Key to search for in lSearch_Column2
'               lSearch_Col3    Third column# to search
'               vKey3           Key to search for in lSearch_Column3
'   Example:    sAccess = Table_Lookup(Range("Security"), 3, _
'                                          1, Cells(2,1), 2, Cells(2,3))
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming
    On Error GoTo ErrHandler
    Table_Lookup = Null         'Assume not found
    Dim c As Range
    Dim LastAddress As String
   
    Dim lRow As Long
    Dim lRows As Long
   
    lRows = rngTable.Rows.Count
   
    With Range(rngTable.Cells(1, lSearch_Col1), _
               rngTable.Cells(lRows, lSearch_Col1))
        Set c = .Find(vKey1, LookIn:=xlValues, _
                      LookAt:=xlWhole, MatchCase:=False)
        If Not c Is Nothing Then
            Do
                lRow = c.Row - rngTable.Row + 1
                If lSearch_Col2 <= 0 Then
                    Table_Lookup = rngTable.Cells(lRow, lResult_Col)
                    Exit Function
                ElseIf UCase(rngTable.Cells(lRow, lSearch_Col2)) = _
                       UCase(vKey2) Then
                    If lSearch_Column3 <= 0 Then
                        Table_Lookup = rngTable.Cells(lRow, lResult_Col)
                        Exit Function
                    ElseIf UCase(rngTable.Cells(lRow, lSearch_Col3)) = _
                        UCase(vKey3) Then
                        Table_Lookup = rngTable.Cells(lRow, lResult_Col)
                        Exit Function
                    End If
                End If
                LastAddress = c.Address
                With Range(rngTable.Cells(lRow, lSearch_Col1), _
                           rngTable.Cells(lRows, lSearch_Col1))
                    Set c = .Find(vKey1, LookIn:=xlValues, _
                                  LookAt:=xlWhole, MatchCase:=False)
                End With
            Loop While Not c Is Nothing And c.Address <> LastAddress
        End If
    End With
ErrHandler:
   
    If Err.Number <> 0 Then MsgBox _
        "Table_Lookup - Error#" & Err.Number & vbCrLf & _
        Err.Description, vbCritical, "Error", Err.HelpFile, Err.HelpContext
    On Error GoTo 0
End Function
 

May 31, 2010  4:04 PM

Check Entry – Initialize Globals

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker
You are here (Click to enlarge)

You are here (Click to enlarge)

As mentioned in the last post, I have chosen to use globals (variables that can be used by any routine in the entire spreadsheet/project) to keep the routines fast by eliminating repeated lookups for the same information.  An alternative approach would be to pass lengthy parameter lists.  You may want to do that in your code.  I keep wrestling with that one and am tempted to rewrite the routines without globals.  But that is for another time.

“WorkSheet_Activate” assigns values to globals specificly for updating a speadsheet to a database.  “Initialize_Globals” ” assigns values to globals that can be used for simply loading a database or updating it.

It’s all pretty straight forward.  So without futher pontification – here is the code:

These following declarations should go at the top of modTableLoadmodTableLoad contains those routines and data items required by spreadsheets that load data for databases.  This includes database reporting/analytics spreadsheets and database update spreadsheets.

'Relative Column Positions for Detail Field Definitions
Global lColTbl As Long         'Table
Global lColAls As Long         'Alias
Global lColFld As Long         'Field
Global lColKey As Long         'Key
Global lColHdg As Long         'Heading
Global lColSOrd As Long        'Sort Order (1st, 2nd, 3rd, ...)
Global lColSSeq As Long        'Sort Sequence (Asc, Dsc)
Global lColFrz As Long         'Freeze Field
Global lColSQLF As Long        'SQL Function
Global lColHid As Long         'Hide
Global lColWid As Long         'Width
Global lColFmt As Long         'Format
Global lColXLF As Long         'XL Function
Global lColInp As Long         'Input
Global lColReq As Long         'Required Flag
Global lColVTyp As Long        'Validation Type
Global lColVTbl As Long        'Validation Table
Global lColUpd As Long         'SQL Update Statement Function
Global lColNote As Long        'Notes/Error Messages

 

The following routine is a handler for the activate event in the worksheet that displays records from and permits entries to the database.  It MUST go in the worksheet (it cannot be in a module). 

Public Sub Worksheet_Activate()
    Dim lRow As Long
    Dim s As String
   
    If lColTbl = 0 Or lColACD = 0 Then 'Do once to init globals (for speed)
        Initialize_Globals sFields
               
        If sFields > "" Then
            With Worksheets("Tables").Range(sFields)
                For lRow = 2 To .Rows.Count
                    If .Cells(lRow, lColKey) <> "" And lCol1stKey = 0 Then _
                        lCol1stKey = lRow - 1
                    If .Cells(lRow, lColReq) <> "" And lCol1stReq = 0 Then _
                        lCol1stReq = lRow - 1
                    If .Cells(lRow, lColHdg) = "ACD" Then _
                        lColACD = lRow - 1
                    If .Cells(lRow, lColHdg) = "ERRORS" Then _
                        lColERRORS = lRow - 1
                Next lRow
            End With
        End If
  
    End If
End Sub

The following routine should go in modTableLoad

Function Initialize_Globals(sFieldDefinitions As String) As Boolean
'   Description:Initialize all global fields
'   Parameters: sFieldDefinitions	range name holding field definitions
'   Example:    bResult = Initialize_Globals("Fields")
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming
    On Error GoTo ErrHandler            '
    Initialize_Globals = Failure        'Assume the Worst

    lColTbl = FieldColumn("Table", sFieldDefinitions)
    lColAls = FieldColumn("Alias", sFieldDefinitions)
    lColFld = FieldColumn("Field", sFieldDefinitions)
    lColKey = FieldColumn("Key", sFieldDefinitions)
    lColHdg = FieldColumn("Heading", sFieldDefinitions)
    lColSOrd = FieldColumn("S.Ord", sFieldDefinitions)
    lColSSeq = FieldColumn("S.Seq", sFieldDefinitions)
    lColFrz = FieldColumn("Freeze", sFieldDefinitions)
    lColSQLF = FieldColumn("SQL Func.", sFieldDefinitions)
    lColHid = FieldColumn("Hide", sFieldDefinitions)
    lColWid = FieldColumn("Width", sFieldDefinitions)
    lColFmt = FieldColumn("Format", sFieldDefinitions)
    lColXLF = FieldColumn("XL Func.", sFieldDefinitions)
    lColInp = FieldColumn("Input", sFieldDefinitions)
    lColReq = FieldColumn("Required", sFieldDefinitions)
    lColVTyp = FieldColumn("V.Type", sFieldDefinitions)
    lColVTbl = FieldColumn("V.Tbl", sFieldDefinitions)
    lColUpd = FieldColumn("Upd.Func.", sFieldDefinitions)
    lColNote = FieldColumn("Notes", sFieldDefinitions)
   
    Initialize_Globals = Success        'Successful finish
ErrHandler:
   
    If Err.Number <> 0 Then MsgBox _
        "Initialize_Globals - Error#" & Err.Number & vbCrLf & _
            Err.Description, vbCritical, "Error", Err.HelpFile, _
            Err.HelpContext
    On Error GoTo 0
End Function
 


May 26, 2010  10:33 PM

Validating Data Entries

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker
Practically no one uses Excel to update databases directly.  I think the reason is because we think of Excel as a tool that end users can do whatever they want to with and updating databases requires discipline.  Just using Excel to shotgun records into a database can be disastrous because putting bad data into a database is often far worse than putting no data in at all.  That’s not to say Excel can’t be an excellent tool for updating databases, it just means we have to approach the subject with the same discipline as we would with ‘normal’ or ‘traditional’ programming methods.
 
At the heart of that discipline is good data validation, also known as ‘edit checks’. 
 
Today’s post won’t share any code.  I want to provide an overview of the process before we start coding.  Here is a simple data flow diagram (DFD) to help the discussion.
Check Entry Overview

Check Entry Overview

As always, I use lots of little functions instead of one monolithic program.  In some cases, my purpose is to build a routine that can be used for other circumstances.  In other cases, my purpose is to isolate where changes should occur from places where, in all likelihood, they never should occur.  And in all cases, my purpose is to have small bits of code that perform specific functions that can be thoroughly tested before being placed into production.  That’s no assurance that something won’t go bump in the night (thus every routine has error handling).  Nor does it mean that experience won’t lead us to better methods and thus, changes to underlying code.
 
The first routine is the worksheet’s specific validation controller.  Though it is expected that this routine will require modifications, much of it should not need any changes (and in many cases, I have used it without any modifications).  The first function it performs is one such piece that should not need modification.  It handles some housekeeping such as making sure all global variables have been initialized (I normally don’t like global variables.  I made an exception for speed here) and clearing any previous error indications from the data to be validated.
 
Below the housekeeping piece is a loop that processes all rows, and all cells in those rows.  Within the inner loop is a place where, if you need unique data validation logic, you can put it.  Below the section set asside for your modifications is a routine that handles all the normal data validation stuff, such as checking dates, making sure numeric fields contain numbers, making sure text fields aren’t longer than they should be, converting to upper case when necessary, handling Yes or No flags, simple Excel Table lookups, and database lookups.
 
Database lookups require specific information and so the generic routine really doesn’t handle them.  It passes control back to the worksheet where a template routine awaits your modifications. 
Note: As you can see, things that need your attention, are isolated in the worksheet code.  Things that you should never have to modify are placed in modules.
 
The last function of the Check_Entry routine is to highlight any cells in error with red, provide a brief description of the problem and/or it’s resolution, and communicate back to the calling routine if any errors were found. 
 
That’s the overview.  Next post – we dive into code. 


May 24, 2010  5:11 PM

Building a Library of Routines for Updating – #7

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker

You are here (Click to enlarge)

You are here (Click to enlarge)

As you can see from the simple DFD at right, we are almost done writing update routines.  Hopefully you are asking an important question.  Hopefully you are wondering why I haven’t covered an extremely important topic.  Hopefully you want to know how we make sure the data is correct BEFORE we update anything.

Glad you asked.
 
If you click on the DFD you will see a routine we haven’t yet covered worksheet.Check_Entry.  Its purpose is to review the user’s entries and look for any mistakes it can catch.  As a programmer – you know that this is perhaps the hardest part of coding because it can change with every application.  Since Check_Entry can be ‘worksheet’ specific, I place a unique instance of Check_Entry in any worksheet that updates data.  And given that I sometimes create workbooks that contain multiple worksheets that update data, I cannot place Check_Entry in a generic module without modifying the routine I’m going to present today.
 
This routine first calls the Check_Entry routine of the worksheet that called it.  There MUST be a routine named Check_Entry there.  Happily, it is quite possible that almost all of your Check_Entry routines will require no modification.  But it is almost certain that if you do more than a few of these spreadsheets, you are going to run into a data requirement that is so unique that the generic routines I will provide simply won’t cut it, in which case, you’re going to need to make some modifications to Check_Entry.
 
So back to today’s routine.  As I said, this routine first calls Check_Entry and if Check_Entry reports no errors, this routine then passes control down to the routines you’ve been adding to your library.  I’ve never had to modify any of these update routines and I fully expect that once you have placed them in your library, you can pretty much forget all about them.
Here is the code for Post:
 
 
Function Post(sConnect As String, sWorksheet As String, _
              sHeaderFields As String, sDetailFields As String, _
              sHeaderRange As String, sDetailRange As String, _
              sTable As String) As Boolean
'   Description:Post entries from a spreadsheet to a database table
'   Parameters: sWorksheet      Worksheet containing entries
'               sHeaderFields   Header Field descriptions range
'                               (on Tables Tab - Optional)
'               sDetailFields   Detail Field descriptions range
'               sHeaderRange    Range containing values common to all
'		              update records (Optional)
'               sDetailRange    Range containing entry rows
'               sTable          Table Name that will be updated
'			    (there can be only one)
'   Example:    bResult = Post(sConnectionString, _
'                              sDataWorkSheet, _
'                              sHeaderFieldDefinitions, _
'                              sDetailFieldDefinitions, _
'                              sHeaderData, _
'                              sDetailData, _
'                              sUpdateTable)
'     Date   Init Modification
'   01/12/06 CWH  Initial Programming
   
    On Error GoTo ErrHandler    '
    Post = Failure              'Assume Something went wrong
   
    Settings "Save"             'Save current application settings
    Settings "Disable"          'Disable events, calcs, screen updates
   
    Dim lRow As Long
    Dim bResult As Boolean
   
    bResult = Worksheets(sWorksheet).Check_Entry( _
                  Range(sDetailRange & "_Data"), _
                  sDetailRange, sDetailFields)
    If bResult <> Success Then
        MsgBox "Errors exist.  " & _
               "Correct first, the press 'Done'", vbOKOnly, "Errors"
    Else
        bResult = Update_Entries(sConnect, sWorksheet, _
                                 sHeaderRange, sDetailRange, _
                                 sHeaderFields, sDetailFields, _
                                 sTable, True)
    End If
   
    Post = bResult
   
ErrHandler:
   
    If Err.Number <> 0 Then MsgBox _
        "Post - Error#" & Err.Number & vbCrLf & Err.Description, _
        vbCritical, "Error", Err.HelpFile, Err.HelpContext
    Settings "Restore"              'Restore application settings
    On Error GoTo 0
End Function
 
 


May 18, 2010  4:11 PM

Building a Library of Routines for Updating – #6

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker
Your are here (Click to enlarge)

Your are here (Click to enlarge)

This post’s routine, Update_Entries, cycles through all the records in an Excel range and updates any pending entries using the Update_Entry function from last post.

You may wonder why I have a single record update routine (SRUR) and a multiple record update routine (MRUR).  Why not just write a larger routine that does both?  The answer is that by having an SRUR, I can test that specific functionality very easily and I have what amounts to an entry point into the MRUR when I want to update just one record.  Since the MRUR leverages the SRUR, none of the SRUR code is duplicated in the MRUR except error handling.  However, having the routines split does cause one problem - mutliple database opens and closes.

Multliple database opens and closes slows things down dramatically.  In order to maintain speed, the SRUR accepts a connection object as well as a connection string.  If the connection object is provided, the SRUR leverages that and avoids creating its own connection to the database.  So to support that goal, we have a routine that creates a connection object that can be passed between functions – SQLConnection.

Here is the code:

Function SQLConnection(cn As ADODB.Connection, _
                       sConnect As String) As Boolean
'   Description:Create a connection to the database
'               By externalizing this, a connection can be created and reused
'   Parameters: cn - an ADODB connection object
'               sConnect - a connection string
'   Example:    bResult =  SQLConnection( _
                           cn, _
                           "Driver={Microsoft Access Driver (*.mdb)};" & _
                           "DBQ=c:\Northwind.mdb")
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming
    On Error GoTo ErrHandler
    SQLConnection = Failure    'Assume Something went wrong
   
    If cn Is Nothing Then
        Set cn = New ADODB.Connection
        cn.Properties("Prompt") = adPromptComplete
        cn.Open sConnect, "", ""
    End If
   
    SQLConnection = Success
   
ErrHandler:
   
    If Err.Number <> 0 Then MsgBox _
        "SQLConnection - Error#" & Err.Number & vbCrLf & Err.Description, _
        vbCritical, "Error", Err.HelpFile, Err.HelpContext
    On Error GoTo 0
End Function
Public Function Update_Entries(sConnect As String, sWorksheet As String, _
                               sHeaderRange As String, sDetailRange As String, _
                               sHeaderFields As String, sDetailFields As String, _
                               sTable As String, bRows As Boolean) As Boolean
'   Description:Update a ALL entries (entires MUST be verfied first)
'   Parameters: sConnect       ODBC Connection String
'               sWorksheet     Worksheet containing data
'               sHeaderRange   Range holding values common to all records (Opt.)
'               sDetailRange   Range holding unique rows of data
'               sHeaderFields  Range holding common field descriptions (Opt.)
'               sDetailFields  Range holding unique row field descriptions
'               sTable         Table to be updated (there can be only one)
'               bRows          "True" if entries in rows, "False" if in columns
'   Example:    bResult = Update_Entries(sConnectionString, _
                                         sDataWorkSheet, _
                                         sHeaderData, _
                                         sDetailData, _
                                         sHeaderFieldDefinitions, _
                                         sDetailFieldDefinitions, _
                                         sUpdateTable, _
                                         True)
'     Date   Init Modification
'   01/12/06 CWH  Initial Programming
    On Error GoTo ErrHandler
    Update_Entries = Success    'Assume the Best 
    
    Settings "Save"             'Save current application settings
    Settings "Disable"          'Disable events, calcs, screen updates
   
    Dim lRow As Long            'Current Row
    Dim lRows As Long           'Number of Rows in sDetailRange
    Dim iACD As Integer         'Column holding ACD (Add,Change,Delete) instr.
    Dim iErrMsg As Integer      'Column to report Error Messages
    Dim bResult As Boolean      'Generic Result variable (Success or Failure)
    Dim cn As ADODB.Connection  'ADO Connection Object (Optional-use this when
                                'updating several records to avoid unnecessary
                                'DB opens and closes)
       
    'Establish connection to the database or fail this routine
    bResult = SQLConnection(cn, sConnect)
    Update_Entries = bResult
    If bResult = Failure Then Exit Function
  
    iACD = FieldColumn("ACD", sDetailRange)         'Must have "ACD" column
    iErrMsg = FieldColumn("ERRORS", sDetailRange)   'and an "ERRORS" column
    lRows = Range(sDetailRange).Rows.Count          'Number of data rows
    With frmProgress                                'Show Progress Bar
        .pPct = 0
        .pCaption = "Updating Entries"
        .Show False
    End With
                       
    Debug.Print "Start: "; Now()                'Start timer(for pgmr feedback)
    With Range(sDetailRange)                    'Go through all records
        lRow = 2                                'Skip column headings
        While lRow <= .Row + .Rows.Count        'Update the database
            If .Cells(lRow, iACD) > "" And _
                InStr(1, "ACD", .Cells(lRow, iACD)) > 0 Then
                bResult = Update_Entry(sConnect, sWorksheet, _
                                       sHeaderRange, sDetailRange, _
                                       sHeaderFields, sDetailFields, _
                                       sTable, lRow, iACD, iErrMsg, cn)
                If bResult = Failure Then Update_Entries = Failure
            End If
            lRow = lRow + 1
            frmProgress.pPct = lRow / lRows
        Wend
       
        lRow = 2                                'Remove deteled rows
        While lRow <= .Row + .Rows.Count
            If .Cells(lRow, iACD) = "D" And _
               .Cells(lRow, iErrMsg) = "Updated!" Then
                Rows(.Cells(lRow, 1).Row).Delete Shift:=xlUp
            Else
                lRow = lRow + 1
            End If
        Wend
    End With
    Debug.Print "End: "; Now()                  'Stop the update timer
               
    cn.Close                                    'Close connection
    frmProgress.Hide                            'Close Progress Bar
ErrHandler:
   
    If Err.Number <> 0 Then MsgBox _
        "Update_Entries - Error#" & Err.Number & vbCrLf & _
        Err.Description, vbCritical, "Error", Err.HelpFile, Err.HelpContext
    Settings "Restore"                  'Restore application settings
    On Error GoTo 0
End Function
 


May 12, 2010  7:47 PM

Building a Library of Routines for Updating – #5

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker
You are here (click to enlarge)

You are here (click to enlarge)

We’re still building the routines necessary to update a database from entries in Excel.  The thumbnail at right is a simple data flow diagram that shows how these routines fit together.  Click on it to enlarge it.  We’ve been working from the bottom up and now we are on what this diagram has as step 8 – Update_Entry.  

Update_Entry updates a single record.  Its parent handles cycling through all Excel entries, passing them one by one to Update_Entry.  We will see that routine in the next post.  Here is the code for Update_Entry.

Public Function Update_Entry(sConnect As String, sWorksheet As String, _
                             sData As String, sFields As String, _
                             sPath As String, lRow As Long, _
                             iACD As Integer, iNotes As Integer, _
                             Optional cn As ADODB.Connection) As Boolean
'   Description:Update a single entry.  Entries MUST be verfied correct
'               before calling this routine.
'   Parameters: sConnect    ODBC Connection String. Leave blank if the
'                           Connection Object (see cn) is created outside
'                           this routine.
'               sWorksheet  Worksheet's name that contains the data
'               sData       Range's name containing the unique rows of data
'               sFields     Range's name containing field descriptions
'               sPath       Table with path (if needed) to update
'               lRow        XL row containing data to be updated/inserted
'               iACD        XL column for ACD entries (Add,Change,Delete)
'               iNotes      XL column to post error messages
'               cn          Persistent connection object.  Use for speedy
'                           updating of multiple records.
'   Example:    bResult = Update_Entry(sConnectionString, _
'                                      "Data", _
'                                      "Data", _
'                                      "Fields", _
'                                      sUpdateTable, _
'                                      lCurrentRow, _
'                                      FieldColumn("ACD","Data"),
'                                      FieldColumn("ERRORS","Data"),
'                                      cn)
'     Date   Init Modification
'   01/12/06 CWH  Initial Programming
    On Error GoTo ErrHandler
    Update_Entry = Failure      'Assume the worse
      
    Settings "Save"             'Save current application settings
    Settings "Disable"          'Disable events, calcs, screen updates
       
    Dim lCol As Long            'Current Column
    Dim sSQL As String          'SQL string
    Dim sCRTB As String         'Carriage Return and two Tabs
    Dim bOpen As Boolean        'Was Connection open when routine called?
           
    sCRTB = vbCr & vbTab & vbTab
   
    'If the Connection wasn't created by the calling routine, make one
    bOpen = Not cn Is Nothing
    If Not bOpen Then
        If SQLConnection(cn, sConnect) = Failure Then Exit Function
    End If
   
    With Range(sData)
              
        'Check Entries. Notes should be blank and ACD should not be "X"
        If .Cells(lRow, iNotes) > "" Then Exit Function
       
        'Update Entries
        sSQL = ""
        Dim sTable As String    'Table without Path
        Dim sSlash As String    'Path seperator used
        sSlash = IIf(InStr(1, "/", sPath) > 0, "\", "/")
        sTable = Right(sPath, Len(sPath) - _
                    Chars_Last_Position(sSlash, sPath))
        Select Case UCase(.Cells(lRow, iACD))
            Case Is = "A"
                sSQL = vbCr & _
                    "Insert Into " & sPath & " " & sCRTB & "(" & _
                        Build_SQL_Insert_Fields(sFields, sTable) & _
                            ") " & vbCr & _
                    "Values (" & _
                        Build_SQL_Insert_Values(sFields, sTable, _
                            sData, lRow - 1, True) & ") "
            Case Is = "C"
                sSQL = vbCr & _
                    "Update  " & sPath & " " & vbCr & _
                    "Set     " & _
                        Build_SQL_Update_Values(sFields, sTable, _
                            sData, lRow - 1, True) & " " & vbCr & _
                    "Where   " & _
                        Build_SQL_UpdDlt_Where_Clause(sFields, sTable, _
                            sData, lRow - 1, True)
            Case Is = "D"
               sSQL = vbCr & _
                    "Delete  From " & sPath & " " & vbCr & _
                    "Where   " & _
                        Build_SQL_UpdDlt_Where_Clause(sFields, sTable, _
                            sData, lRow - 1, True)
        End Select
   
        If sSQL > "" Then
            Debug.Print sSQL
            cn.Execute sSQL
            If cn.Errors.Count = 0 Then
                .Cells(lRow, iNotes) = "Updated!"
                Update_Entry = Success          'Successful finish
                If (.Cells(lRow, iACD)) <> "D" Then _
                    .Cells(lRow, iACD) = "X"
            Else
                .Cells(lRow, iNotes) = "Errors prevented updating. " & _
                    cn.Errors(0).Description
            End If
        End If
       
    End With
   
ErrHandler:
   
    If Err.Number <> 0 Then MsgBox _
        "Update_Entry - Error#" & Err.Number & vbCrLf & Err.Description, _
        vbCritical, "Error", Err.HelpFile, Err.HelpContext
    On Error Resume Next
    Range(sData).Cells(lRow, iNotes) = "Errors prevented updating. " & _
        cn.Errors(0).Description
    If Not bOpen Then cn.Close      'Close connection if opened here
    Settings "Restore"              'Restore application settings
    On Error GoTo 0
   
End Function


May 6, 2010  8:34 PM

Building a Library of Routines for Updating – #4

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker

We are just about finished with adding support routines for updating, inserting, and deleting records in a database.  As a reminder, these routines should never need modification. 

The first routine should go in modSQL.  It is used to create a connection object that can be reused.  This can greatly speed processing be eliminating constently opening and closing database connections for each insert, update, or delete.

The second routine finds the last position of a character in a string.  This is used to strip table/file names from path strings.  It can have other applications and thus, should be place in modGeneral.

Function SQLConnection(cn As ADODB.Connection, _
                       sConnect As String) As Boolean
'   Description:Create a connection to the database
'               By externalizing this, a connection can be reused
'   Parameters: cn          an ADODB connection object
'               sConnect    Connection string
'   Example:    bResult = _
                    SQLConnection(cn, _
'                       "Driver={Microsoft Access Driver (*.mdb)};" & _
'                       "DBQ=c:\Northwind.mdb")
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming
    On Error GoTo ErrHandler
    SQLConnection = Failure    'Assume Something went wrong
   
    If cn Is Nothing Then
        Set cn = New ADODB.Connection
        cn.Properties("Prompt") = adPromptComplete
        cn.Open sConnect, "", ""
    End If
   
    SQLConnection = Success
   
ErrHandler:
   
    If Err.Number <> 0 Then MsgBox _
        "SQLConnection - Error#" & Err.Number & vbCrLf & Err.Description, _
        vbCritical, "Error", Err.HelpFile, Err.HelpContext
    On Error GoTo 0
End Function
 
Function Chars_Last_Position(sCharacter As String, _
                             sString As String) As Integer
'   Description:Returns position of last occurance of a character
'               in a string
'   Parameters: sCharacter  Character to find
'               sString     String to search for character
'   Example:    sTable = Right(sPath, len(sPath) - _
'                           Chars_Last_Position("/", sPath))
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming
    On Error GoTo ErrHandler
    Dim i As Integer
   
    Chars_Last_Position = 0         'Assume not found
   
    i = 0
    Do
        i = InStr(i + 1, sString, sCharacter, vbTextCompare)
        If i > 0 Then Chars_Last_Position = i
    Loop Until i = 0
   
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
 


April 28, 2010  4:15 PM

Building a Library of Routines for Updating – #3

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker
You are here (click to enlarge)

You are here (click to enlarge)

This post provides “insert” functionality which adds records to tables.  The basic syntax of an SQL Insert statement is: 

 

INSERT INTO table_name (column1, column2, column3,...) VALUES (value1, value2, value3,...)
To build this statement, we have two routines.  One creates a string of column/field names and the other creates a string of values.  The column/field names come from the Fields Defnition table.  The values come from the end user’s entries in the “Data” range.
Function Build_SQL_Insert_Fields(sFields As String, sTable As String) As String
'   Description:Format field/column names for an SQL "Insert" statement
'               Use Build_SQL_Insert_Values to add associated values
'   Parameters: sFields:Range name containing field definitions
'                       Field:  Database Field/Column names
'                       Key:    Which fields are part of the unique key
'                       Table:  Database table/file name to update
'               sTable: Database table/file name to update
'   Example:    sSQL = _
'                   "Insert Into " & sTable & " (" & _
'                    Build_SQL_Insert_Fields("Fields", sTable) & ") " & _
'                   "Values (" & _
'                    Build_SQL_Insert_Values("Fields",sTable,"Data",1,True) & ") "
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming
    On Error GoTo ErrHandler
    Build_SQL_Insert_Fields = ""    'Assume Something went wrong
    Dim lRow As Long
    Dim sSQL As String
   
    If sFields <= "" Then Exit Function
   
    sSQL = ""
    With Range(sFields)
        For lRow = 2 To .Rows.Count
            'Skip fields that are part of Primary Key or not part of update table 
            If .Cells(lRow, FieldColumn("Table", sFields)) = _
                sTable And .Cells(lRow, FieldColumn("Key", sFields)) <> "A" Then _
                    sSQL = sSQL & IIf(sSQL > "", ", ", "") & _
                       .Cells(lRow, FieldColumn("Field", sFields))
        Next lRow
    End With
   
    Build_SQL_Insert_Fields = sSQL
ErrHandler:
   
    If Err.Number <> 0 Then MsgBox _
        "Build_SQL_Insert_Fields - Error#" & Err.Number & vbCrLf & Err.Description, _
        vbCritical, "Error", Err.HelpFile, Err.HelpContext
    On Error GoTo 0
End Function

 

Function Build_SQL_Insert_Values(sFields As String, sTable As String, _
                                 sDataRange As String, lRecord As Long, _
                                 bRows As Boolean) As String
'   Description:Format field/column values for an SQL "Insert" statement
'               Use Build_SQL_Insert_Fields to add associated Field/Column names
'   Parameters: sFields:Range name containing field definitions
'                       Field:  Database Field/Column names
'                       Key:    Which fields are part of the unique key
'                       Table:  Database table/file name to update
'               sTable: Database table/file name to update
'               sDataRange: Range name that holds the values/data
'               lRecord:Record in sDataRange being updated (Row# if bRows=True)
'               bRows:  True means each record is in a row
'   Example:    sSQL = _
'                   "Insert Into " & sTable & " (" & _
'                    Build_SQL_Insert_Fields("Fields", sTable) & ") " & _
'                   "Values (" & _
'                    Build_SQL_Insert_Values("Fields",sTable,"Data",1,True) & ")"
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming
    On Error GoTo ErrHandler
    Build_SQL_Insert_Values = ""    'Assume Something went wrong
   
    Dim lRow As Long
    Dim sSQL As String
    Dim sCRTB As String
    Dim sValue As String    	'Current field Value
    Dim sScreenField As String  	'Field's Screen Name
    sCRTB = vbCr & vbTab & vbTab
   
    If sFields <= "" Then Exit Function
   
    sSQL = ""
    With Range(sFields)
        For lRow = 2 To .Rows.Count
            'Skip fields not part of the table or part of an Auto ID
            If .Cells(lRow, FieldColumn("Table", sFields)) = sTable And _
                .Cells(lRow, FieldColumn("Key", sFields)) <> "A" Then
                sScreenField = .Cells(lRow, FieldColumn("Heading", sFields))
                If bRows Then
                    sValue = Range(sDataRange).Cells(lRecord + 1, _
                             FieldColumn(sScreenField, sDataRange))
                Else
                    sValue = Range(sDataRange).Cells( _
                             FieldRow(sScreenField, sDataRange), lRecord + 1)
                End If
                sSQL = sSQL & IIf(sSQL > "", ", " & sCRTB, "") & _
                    SQL_Add_Update_Functions(sValue, lRow, sFields)
            End If
        Next lRow
    End With
   
    Build_SQL_Insert_Values = sSQL
ErrHandler:
   
    If Err.Number <> 0 Then MsgBox _
        "Build_SQL_Insert_Values - Error#" & Err.Number & vbCrLf & _
        Err.Description, vbCritical, "Error", Err.HelpFile, Err.HelpContext
    On Error GoTo 0
End Function
 


April 20, 2010  1:16 PM

Building a Library of Routines for Updating – #2

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker
You are here (Click to enlarge)

You are here (Click to enlarge)

Last post provided SQL_Add_Update_Funtions.  This entry provides the next level up to the routines that relies on SQL_Add_Update_Functions.  The basic syntax of an SQL Update statement is:

UPDATE table_name
SET    column1=value, column2=value2,...
WHERE  some_column1=some_value1
  AND  some_column2=some_value2 ...

To build this statement, we have two routines.  One creates the “column=value” pairs of the “SET” clause , and the other creates the “WHERE” clause.    The column/field names come from the Fields Definition Table and the values come from the end user’s entries in the “Data” range.

There’s not any magic in either of these routines and I believe the in-code documentation expains things well enough, so without any further pontification, here are the next set of routines to add.  These should go into “modTableUpdate”.

Function Build_SQL_Update_Values(sFields As String, sTable As String, _
                                 sDataRange As String, lRecord As Long, _
                                 bRows As Boolean) As String
'   Description:Format field/column names & values for an SQL "Update" statement
'   Parameters: sFields:Range name containing field definitions
'                       Field:  Database Field/Column names
'                       Key:    Which fields are part of the unique key
'                       Table:  Database table/file name to update
'               sTable: Database table/file name to update
'               sDataRange: Range name that holds the values/data
'               lRecord: Record in sDataRange being updated (Row# if bRows=True)
'               bRows:  True means each record is in a row
'   Example:   
'	sSQL = _
'            "Update  " & sTable & " " & _
'            "Set    " & _
'             Build_SQL_Update_Values("Fields","Products","Data",1,True) & " " & _
'            "Where   " & _
'             Build_SQL_UpdDlt_Where_Clause("Fields","Products","Data",1,True)
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming
    On Error GoTo ErrHandler
    Build_SQL_Update_Values = "" 'Assume Something went wrong
   
    Dim lRow As Long
    Dim sSQL As String
    Dim sCRTB As String
    Dim sValue As String        'Current Value of the field being processed
    Dim sScreenField As String  'Screen Name of Current Field being processed
    Dim sTableField As String   'Table Name of Current Field being processed
    sCRTB = vbCr & vbTab & vbTab
    If sFields <= "" Then Exit Function
   
    sSQL = ""
    With Range(sFields)
        For lRow = 2 To .Rows.Count
            'Include only fields from stable and not part of the Primary Key
            If .Cells(lRow, FieldColumn("Table", sFields)) = sTable And Not _
                .Cells(lRow, FieldColumn("Key", sFields)) >= "A" Then
                sTableField = .Cells(lRow, FieldColumn("Field", sFields))
                sScreenField = .Cells(lRow, FieldColumn("Heading", sFields))
                If bRows Then
                    sValue = Range(sDataRange).Cells(lRecord + 1, _
                             FieldColumn(sScreenField, sDataRange))
                Else
                    sValue = Range(sDataRange).Cells( _
                             FieldRow(sScreenField, sDataRange), _
                             lRecord + 1)
                End If
                sSQL = sSQL & IIf(sSQL > "", ", " & sCRTB, "") & _
                       sTableField & " = " & _
                       SQL_Add_Update_Functions(sValue, lRow, sFields)
            End If
        Next lRow
    End With
   
    Build_SQL_Update_Values = sSQL
ErrHandler:
   
    If Err.Number <> 0 Then MsgBox _
        "Build_SQL_Update_Values - Error#" & Err.Number & vbCrLf & _
         Err.Description, vbCritical, "Error", Err.HelpFile, Err.HelpContext
    On Error GoTo 0
End Function
 
Function Build_SQL_UpdDlt_Where_Clause(sFields As String, sTable As String, _
				  sDataRange As String, lRecord As Long, _
				  bRows As Boolean) As String
   
'   Description:Create SQL Where clause for SQL "Update" or "Insert" statement
'   Parameters: sFields:Range name containing field definitions
'                       Field:  Database Field/Column names
'                       Key:    Which fields are part of the unique key
'                       Table:  Database table/file name to update
'               sTable: Database table/file name to update
'               sDataRange: Range name that holds the values/data
'               lRecord: Record in sDataRange being updated (Row# if bRows=True)
'               bRows:  True means each record is in a row
'   Example:   
'	sSQL = _
'            "Update  " & sTable & " " & _
'            "Set    " & _
'             Build_SQL_Update_Values("Fields","Products","Data",1,True) & " " & _
'            "Where   " & _
'             Build_SQL_UpdDlt_Where_Clause("Fields","Products","Data",1,True)
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming
    On Error GoTo ErrHandler
    Build_SQL_UpdDlt_Where_Clause = ""    'Assume Something went wrong
    Dim lRow As Long
    Dim sSQL As String
    Dim sCRTB As String
    Dim sValue As String        'Current Value of the field being processed
    Dim sScreenField As String  'Screen Name of Current Field being processed
    Dim sTableField As String   'Table Name of Current Field being processed
   
    If sFields <= "" Then Exit Function
   
    sSQL = ""
    With Range(sFields)
        For lRow = 2 To .Rows.Count
            'Include only fields from stable and not part of the Primary Key
            If .Cells(lRow, FieldColumn("Table", sFields)) = _
                sTable And .Cells(lRow, FieldColumn("Key", sFields)) >= "A" Then
                sTableField = .Cells(lRow, FieldColumn("Field", sFields))
                sScreenField = .Cells(lRow, FieldColumn("Heading", sFields))
                If bRows Then
                    sValue = Range(sDataRange).Cells(lRecord + 1, _
                        FieldColumn(sScreenField, sDataRange))
                Else
                    sValue = Range(sDataRange).Cells( _
                             FieldRow(sScreenField, sDataRange), _
                             lRecord + 1)
                End If
                sSQL = sSQL & IIf(sSQL <= "", "", vbCr & "  And   ") & _
                       .Cells(lRow, FieldColumn("Field", sFields)) & " = " & _
                       SQL_Add_Update_Functions(sValue, lRow, sFields)
            End If
        Next lRow
    End With
   
    Build_SQL_UpdDlt_Where_Clause = sSQL
ErrHandler:
   
    If Err.Number <> 0 Then MsgBox _
        "Build_SQL_UpdDlt_Where_Clause - Error#" & Err.Number & vbCrLf & _
        Err.Description, vbCritical, "Error", Err.HelpFile, Err.HelpContext
    On Error GoTo 0
End Function


April 15, 2010  8:10 AM

Building a Library of Routines for Updating – #1

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker
You are here (Click to enlarge)

You are here (Click to enlarge)

As mentioned before, we will be re-using the routines created for the reporting side. And just like we did for the reporting side of things, we need to build a library of routines before we can actually start using them to assemble applications.  This will take several posts because I use several small functions to perform specific tasks in the process (as opposed to a larger monolithic routine).  I prefer coding this way because I can test each routine more thoroughly if the code is kept simple and the functionality kept focused. 

You can get an overall view of the routines by clicking the diagram at right.

The first routine is SQL_Add_Update_Functions. This routine converts Excel formatted information into SQL friendly formats. For example, if the field in the database is character based, we need to surround the value entered in Excel with single quotes. Another example common to legacy systems is conversion of dates from Excel’s human friendly formats to system required formats, such as Julian dates (or more correctly “ordinal dates“). And on that note, to support SQL_Add_Update_Functions I have included the date format conversion routine Date2Julian and its sister Julian2Date.

By-the-way, I recommend that you create a separate module “modTableUpdate” and add SQL_Add_Update_Functions to it, along with the other routines we will add that will not require modification but are unique to spreadsheets that update databases. By having these routines in their own module, you can better manage them and include them as needed. I also recommend Date2Julian and Julian2Date be placed in “modGeneral” since they have broader applications.

  

Function SQL_Add_Update_Functions(sValue As String, lRow As Long, _
                                  sFields As String) As String
'   Description:Format XL data into SQL friendly formats
'   Parameters: sValue      An individual value to be posted to the database
'               lRow        Record within sFields describing field to hold sValue
'                           NOTE: This is equal to 'Field' number + 1
'               sFields     Field Definition range name
'   Example:    Debug.Print SQL_Add_Update_Functions("02/10/10", 2, "Fields")
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming
    On Error GoTo ErrHandler
    SQL_Add_Update_Functions = ""    'Assume Something went wrong
    sValue = Replace(sValue, "'", "`")
    With Range(sFields)
        Select Case UCase(.Cells(lRow, FieldColumn("Upd.Func.", sFields)))
            Case Is = "DATE2JULIAN" 
                If IsDate(sValue) Then
                    sValue = Date2Julian(sValue)
                Else
                    sValue = "NULL"
                End If
            Case Is = "DATE"
                If IsDate(sValue) Then
                    sValue = "'" & sValue & "'"
                Else
                    sValue = "NULL"
                End If
            Case Is = "HHMMSS"
                If IsNumeric(sValue) Then
                    sValue = sValue - Int(sValue)
                    sValue = "'" & Format(sValue, "hh:mm:ss") & "'"
                Else
                    sValue = "NULL"
                End If
            Case Is = "HHMM"
                If IsNumeric(sValue) Then
                    sValue = sValue - Int(sValue)
                    sValue = "'" & Format(sValue, "hh:mm") & "'"
                Else
                    sValue = "NULL"
                End If
            Case Is = "TRIM"
                sValue = "'" & Trim(sValue) & "'"
            Case Is = "VAL"
                If IsNumeric(sValue) Then
                    sValue = Val(sValue)
                Else
                    sValue = "NULL"
                End If
            Case Else
                If .Cells(lRow, FieldColumn("Format", sFields)) > "" Then
                    sValue = "'" & _
                        Format(sValue, _
                              .Cells(lRow, FieldColumn("Format", sFields))) & "'"
                Else
                    sValue = "'" & sValue & "'"
                End If
        End Select
    End With
   
    SQL_Add_Update_Functions = sValue
ErrHandler:
   
    If Err.Number <> 0 Then MsgBox _
        "SQL_Add_Update_Functions - Error#" & Err.Number & vbCrLf & _
            Err.Description, vbCritical, "Error", Err.HelpFile, Err.HelpContext
    On Error GoTo 0
End Function
 
Function Date2Julian(sDate As String) As String
   
'   Date2Julian:    Converts MM/DD/YYYY to YYYYDDD
'   Parameters:     sDate - the date to convert
'   Example:        sJulian = Date2Julian(format(now(), "mm/dd/yyyy"))
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming
    On Error GoTo ErrHandler
    Date2Julian = "2000001"
    Dim dDate As Date   
    dDate = DateValue(sDate)
    Date2Julian = Year(dDate) & _
                  Format(dDate - DateValue("01/01/" & Year(dDate)) + 1, "000")
   
ErrHandler:
   
    If Err.Number <> 0 Then MsgBox _
        "Date2Julian - Error#" & Err.Number & vbCrLf & Err.Description, _
        vbCritical, "Error", Err.HelpFile, Err.HelpContext
    On Error GoTo 0
End Function
 
Function Julian2Date(sJulian As String) As Date
'   Julian2Date:    Converts YYYYDDD to MM/DD/YYYY
'   Parameters:     sJulian - the Julian date to convert
'   Example:        dPosted = Julian2Date("2009002")
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming
    On Error GoTo ErrHandler
    Julian2Date = "01/01/01"
    Julian2Date = DateValue("01/01/" & _
                  Left(sJulian, 4)) + Val(Right(Trim(sJulian), 3)) - 1
   
ErrHandler:
   
    If Err.Number <> 0 Then MsgBox _
        "Julian2Date - 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: