Beyond Excel: VBA and Database Manipulation


August 9, 2010  8:13 PM

Check Entry – Worksheet_Change – Code

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker

Last post we discussed the theory behind the WorkSheet_Change event code below.  This code must be in the WorkSheet class as it only responds to events for the worksheet that contains it.  Here is the code: 

Private Sub Worksheet_Change(ByVal Target As Range)

 

   Purpose:    Invoke routines to set/check the contents of entry cells

 

   Parameters: Target      Range that was changed

 

   Example:    None – this is an event handler

 

    On Error GoTo ErrHandler

   

    Dim bResult As Boolean

   

    Settings “Save”                 ‘Save current application settings

    Settings “Disable”              ‘Disable events, screen updates, & calcs

       

   Determine the last key pressed

    Dim sKey As String

    Dim lRow As Long

    Dim lCol As Long

    If GetAsyncKeyState(vbKeyTab) And &H8000 Then

        If GetAsyncKeyState(vbKeyShift) And &H8000 Then

            sKey = “ShiftTab”

            lCol = lCol – 1

        Else

            sKey = “Tab”

            lCol = lCol + 1

        End If

    ElseIf GetAsyncKeyState(vbKeyRight) And &H8000 Then

        sKey = “Right”

        lCol = lCol + 1

    ElseIf GetAsyncKeyState(vbKeyLeft) And &H8000 Then

        sKey = “Left”

        lCol = lCol – 1

    ElseIf GetAsyncKeyState(vbKeyPageUp) And &H8000 Then

        sKey = “PageUp”

        lRow = lRow – 1

    ElseIf GetAsyncKeyState(vbKeyUp) And &H8000 Then

        sKey = “Up”

        lRow = lRow – 1

    ElseIf GetAsyncKeyState(vbKeyDown) And &H8000 Then

        sKey = “Down”

        lRow = lRow + 1

    ElseIf GetAsyncKeyState(vbKeyPageDown) And &H8000 Then

        sKey = “PageDown”

        lRow = lRow + 1

    ElseIf GetAsyncKeyState(vbKeyReturn) And &H8000 Then

        sKey = “Return”

        lRow = lRow + 1

    Else

        sKey = “Mouse”

    End If

       

   Disallow all total column oriented actions

    If Target.Rows.Count = Me.Rows.Count Then

        Application.Undo

        MsgBox “You  may not paste, delete, or insert columns”, _

            vbInformation, “Column changes not allowed”

   

   Allow without checking all total row oriented actions _

    that are below the header row.  Execute the code below for all else

    ElseIf Target.Columns.Count < Me.Columns.Count _

        Or Target.Row <= Range(sData).Row Then

          

          

   Handle pasting ‘locked’ cells

       Remember Current Cursor Position

        Dim rngSelection As Range

            Set rngSelection = Selection

 

       Restrict Target to appropriate range

        Set Target = Intersect(Target, _

                     Range(sData).EntireColumn, _

                     Rows(Range(sData).Row + 1 & “:” & Me.Rows.Count))

           

       Remember Target

        Dim rngCell As Range

        Dim colAddress As New Collection

        Dim colValue As New Collection

        If Not Target Is Nothing Then

            For Each rngCell In Target

                colAddress.Add rngCell.Address

                colValue.Add rngCell.Value

            Next

        End If

   

        Application.Undo    ‘Undo Changes

   

       Repaste values to unlocked cells as unlocked cells

        Dim i As Integer

        For i = 1 To colAddress.Count

            If Not Range(colAddress.Item(i)).Locked Then _

                Range(colAddress.Item(i)) = colValue.Item(i)

        Next i

 

        rngSelection.Select      ‘Restore Selection

       

       Detail

        Cell_UnChecked Target

        If NameExists(sData) Then

            bResult = Set_Entry_Defaults(Target, sData, sFields)

            If bResult = Success Then Check_Entry Target, sData, sFields

            Format_New_Line sData, sFields

        End If

       

        If bResult <> Success Then Set Target = Selection

        Position_Cursor_In_Data _

            Target.Cells(1 + lRow, 1 + lCol), Range(sData), sKey

       

    End If

           

   

ErrHandler:

   

    If Err.Number <> 0 Then MsgBox _

        Me.Name & “.WorkSheet_Change – Error#” & Err.Number & vbCrLf & _

        Err.Description, vbCritical, “Error”, Err.HelpFile, Err.HelpContext

    On Error Resume Next

    Settings “Restore”              ‘Restore application settings

    On Error GoTo 0

 

End Sub

 

August 6, 2010  5:21 PM

Check Entry – Worksheet_Change – Theory

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker
There are two times when you want to check entries:
  1. When the user changes something and 
  2. When they want to post entries to the database (aka add, change or delete data). 

Last post covered the second situation.  This covers the first.

Excel provides a rich user interface.  That’s why people like it.  They can do just about anything.  They can move anywhere on the spreadsheet.  Select things.  Move things.  Copy things.   Paste things.  Delete things.  Insert things.

As a developer, we like things controlled.  We want to limit what the user can and cannot do.  We want to guide them carefully through data entry.  We want to check every entry they make.  Control is in direct opposition to the freedom Excel offers, the freedom users love.  Control is required to prevent data corruption.  Striking a balance between control and freedom is tough.  It’s taken me a while to find a balance between the two and the heart of that balance is focused in the WorkSheet_Change event.

Here is the basic flow of this routine:

  • If an entire column is changed (move, paste, insert or delete), the change is thrown out
  • If an entire row is changed and it is in the target entry area, the change is accepted without checking
  • If a cell is locked, any change is removed and the original cell values restored

     -Otherwise_
     

  • First: The system attempts to conform the entry to rules implemented in Set_Entry_Defaults.  An example is converting text to upper case as dictated by values in the Fields Definition Table under the validation columns 
     
  • Second: If this is the first entry in a new row, the system attempts to apply default values for every column.  An example is automatically putting today’s date in an “ENTERED” column and the user’s ID in an “ENTERED BY” column.
     
  • Third: If a single cell is changed and Field Definition Table indicates it is checked by one of the Table Validation rules (XLC, XLT, CUST), the system will check the value using the rule, and if it fails validation, display a Pop-Up validation/selection window to assist the user in selecting something appropriate.  An example is a Pop-Up validation/selection window showing valid Country Codes for a Country Code entry.
     
  • Fourth: If a code or ID entry has associated values that need to be displayed in the entry row, the system attempts to retrieve those values and display them. An example is the Country Name displayed next to the Country Code.
     
  • Fifth: The system performs a final check
     
  • Sixth: The system attempts to move the cursor to the next appropriate field or record based on the key used to exit the cell.

And here is a partial list of how the user might change things and how this routine handles each circumstance:

  • Typing – The most common change is from the user simply typing into a cell, in which case, everything works as it should and nothing special happens.
     
  • Copy/Paste - This is another common situation and one where Excel offers a great benefit.  Sometimes you have data in another spreadsheet, or in a word document, or on a web page – and if only you could highlight it, copy it, and paste it to a table that would upload to the database, complete with full validation.  Wouldn’t that be great!  Well – this routine handles that – but in an odd sort of way.  The problem is that cells copied from other places are pasted, by default, as locked cells – and locked cells can’t be changed by typing, nor are they validated. 

    Another problem with copy/paste is that there is nothing preventing users from pasting into areas outside the entry area (I do NOT use worksheet protection to permit proper copy/paste into rows with some locked cells between fields).  So when cells are pasted, the system 1) Remembers the pasted cells’ values, 2) Undoes the post, 3) Elminates cells outside the entry area, and 4) carefully pastes values (no formats or lock states) from the pasted cells into only unlocked cells.

    This method works great – but adds processing that slows entry.  If your PC is slow, or your users simply never use copy/paste, you can speed data entry by eliminating this capability from your spreadsheet.

  • Inserting rows – This is allowed but not checked.  It will, of course, be checked when the entry is posted.
     
  • Moving Rows – This is allowed but has no impact on the database.  If you want to allow users to ‘sequence lines’, you need to provide a ‘sequence’ field and handle sequencing in code.
      
  • Deleting Rows – This is allowed but has no affect on the database.  Users should be warned to use the “D” in the ACD column to delete rows in the database.
     
  • Inserting columns – If a user wants more fields, they MUST negotiate with the developer (you) to accomodate everything else that goes with that.  If they attempt it, an error is thrown and the insert is removed as though nothing ever happened.  That’s the way it should be.
     
  • Deleting columns – This is not allowed.  If they attempt it, an error is thrown and the deleted column restored as though nothing ever happened.  That’s the way it should be.
     
  • Moving Columns – This is not allowed.  If a user wants the column order changed, for whatever reason, they should see you.  You can easily change the Field Definitions Table to accomodate such requests.  It is also possible to code ‘formats’ to accomodate different users or different ‘line types’ within a record.  But that requires YOU to code.  If a user attempts to move a column, the column is returned to its proper position.  This is as it should be.
     
  • Inserting cells – This really makes no sense in a traditional row oriented data entry scenario.  If it is attempted, the area that was inserted is blanked out and the displaced cells are returned.  If the blanked cells are marked by the Field Definition Table as required, the record(s) will fail validation and the user must set things right before the system will update the database. 

    This is an opportunity for improvement but my cynical nature is holding me back.  If a user is really trying hard to muck things up (or if they are really that poor of judgement), I don’t mind it if the system makes it hard on them to make it right.
       

  • Deleting Cells – Once again, the user is attempting something that doesn’t make sense in a traditional row oriented database.  And once again, this is an opportunity for improvement.

 That’s the theory behind the WorkSheet_Change event code.  In our next post, we’ll discuss the code.


July 22, 2010  6:59 PM

Check Entry – Post_Click Event

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker
There are two times when you want to check entries:
 
  1. When the user changes something and 
  2. When they want to post entries to the database (aka add, change or delete data). 

Today’s post covers the second situation.  The second situation requires a “Post” button.  We give the user a “Post” button with this command:

Create_Easy_Button “Post”, “Sheet1.Post_Click”, 105, 10

The code for that routine is here:  Code for Easy Button
The “Sheet1.” is the worksheet with the “Post” button on it, AND with the Post_Click routine in it.  It’s possible that your “Data” worksheet isn’t Sheet1.  To determine which sheet it is:
 
  1. Copy the code below to your “Data” worksheet
  2. Use Alt-F8 to bring up the Macros’ list. 
  3. Note the Sheet# name infront of Post_Click.  That’s the Macro name you’ll need.
 
105 is the number of pixels to the right for the upper left corner of your button.  10 is the number of pixels down.
 
If you’ve been following along from the beginning, you have a workable “Update” spreadsheet.  But we have more to do.  We have to wire up the “When the user changes something” event (See bullet #1 at top) and we need to control how the cursor moves from cell to cell so it automatically skips over protected (non-entry) cells.  Stay tuned.  More to come.  Here is today’s code:
 

Sub Post_Click()

 

   Wrapper for Post and Load_Data_Logs tied to “Update Logs” button

 

     Date   Init Modification

   05/22/09 CWH  Initial Programming

   

    On Error Resume Next

   

    Settings “Disable”      ‘Disable events, screen updates & Calc.s

    Worksheet_Activate

    Dim bResult As Boolean

    bResult = Post(sConnect, _

                   Me.Name, _

                   “”, sFields, _

                   “”, sData, _

                   sTable)

    If bResult = Success Then _

        Load_Data False     ‘False means no prompting

    Settings “Clear”        ‘Enable events

   

    On Error GoTo 0

 

End Sub


July 20, 2010  8:48 PM

Check Entry – Initializing Globals

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

You are here (Click to enlarge)

As I have written about this method for creating updates with Excel, I have confessed that I really don’t think some of my choices were the best way.  These questionable choices came about as a result of plowing new ground and attempts to improve speed.  I haven’t changed them solely because I tend to not fix what’s working.  That doesn’t mean you need to stick with what I’ve done.  You have the code.  You have the skills.  Make changes as you see fit.  One of these questionable tactics is today’s topic, initializing globals. 

Originally I wrote totally self contained routines that would pluck what they needed from the Field Definitions file or properties of the Datarange.  This meant these routines had to calculate values already calculated by parent routines or repeatedly as the routine was called within a loop.  To speed execution, I decided to ‘pre-calculate’ these values and make them available to any routine that needed them.  Globals values (variables that can be accessed by any routine in any module) were the first thing that came to mind and they did indeed dramatically improve execution.  So why are they questionable?

As mentioned, the global’s advantage is it can be accessed by any routine in any module.  The global’s disadvantage is it can be changed by any routine in any module.  That opens the door for some unrelated routine to inadvertently, and negatively impact other routines; unexpected things can happen; debugging can be a nightmare. 

Similar to globals are class properties.  Like forms, individual worksheets can have custom properties.  They are setup the same way as forms.  I’ve tried this approach.  My implementation of properties had key values placed in seperate properties which meant my code changes were spread over a significant area of code (I like concentrating where changes are made in a tight section of code).  Another implementation of properties that I tried involved something similar to the ‘Settings’ routine, where I passed a value to the property that indicated which value I wanted returned.  This limited my changes to one place (a good thing) but added speed sapping processing.

Another alternative to the global is to pass all values as parameters down the stack of function calls.  This can result in huge parameter lists that contain some values not related to the routine accepting them.  The keyword is, ‘can’.  I don’t know if that would be the case here because I haven’t explored it.  It may very well be managable.  In addition, passing everything as a parameter down the stack does not prevent parent routines from changing values inappropriately, but it does limit the damage to downstream processes, particularly if you pass parameters by value instead of by reference. 

So now you know the debate that went through my head as I coded this process.  Maybe you know why one method is best.  Maybe you know of an alternative I haven’t explored.  If you do, please share by posting a comment.  But until I figure out which method is best, I’ll stick with one that I know works, and works well.  Below is the code that initializes project wide globals, and worksheet scoped globals.

Worksheet_Activate handles globals limited in scope to the worksheet.  It MUST be placed in the worksheet code area.

Initialize_Globals handles project wide globals.  It CANNOT be placed in the worksheet code area.  It MUST be placed in a module.  I place it in modTableLoad.

 

Public Sub Worksheet_Activate()

 

    Dim lRow As Long

    Dim s As String

   

   ‘Do just once to initialize these globals (for speed)

    If lColTbl = 0 Or lColACD = 0 Then

        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

 

 

 

 

 

Function Initialize_Globals(sFieldDefinitions As String) As Boolean

 

   Description:Initialize all global fields

 

   Parameters: sFieldDefinitions Name of range holding any field definitions

   Example:    bResult = Initialize_Globals(“Fields_Data”)

 

     Date   Init Modification

   01/01/01 CWH  Initial Programming

 

    Initialize_Globals = Failure        ‘Assume the Worst

    On Error GoTo ErrHandler           

 

    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


July 13, 2010  10:12 AM

Check Entry – The Controlling Routine

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

You are here (Click to enlarge)

We have been working from the bottom up and now we get to the routine that controls the validation process: Check_Entry.  I almost never change Check_Entry but I put it in the spreadsheet class along with Cust_Edit because it is meant to be modified for worksheet specific validation rules.

Cust_Edit is a field level validation routine.  Often, that’s all you need.  On some occasions you need record set validations.  Such is the case with journal entries where the sum of debits must equal the sum of credits.  Check_Entry is the perfect place for such record set validations.  To implement a rule like this you could code a debit and a credit tally and check them after looping through the entire entry set.  If the tallies don’t match, set Check_Entry to Failure so the Post routine won’t save anything. 

Here is the code: 

Public Function Check_Entry(rngTarget As Range, _
                            sDataRange As String, _
                            sDataFieldDefinitions As String) As Boolean

'   Description:Determine if an entry is valid or not and NOTHING else
'               DO NOT attempt to correct or change values here
'               Do that in the Set_Entry_Defaults routine.

'   Parameters: rngTarget   Range to be validated
'               sDataRange  Range holding rngTarget and all other entries
'               sDataFieldDefinitions   Range containing field definitions
'                           for sDataRange
'   Example:    Me.Check_Entry Target(Range("Data_Data"), "Data", "Fields")
 
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming
    
    On Err GoTo ErrHandler
    Check_Entry = Success           'Assume the best
    
    If lColACD = 0 Then _
        Worksheet_Activate          'Set globals if needed
        
    Settings "Save"                 'Save current settings
    Settings "Disable"              'Disable events, screen updates, & calcs
           
    Dim lRow As Long                'Current Row
    Dim lCol As Long                'Current Column
    
    Dim lRowData As Long            'First Row of Data
    Dim lColData As Long            'First Column of Data
    Dim lRowsData As Long           'Total Rows in Data
    Dim lColsData As Long           'Total Columns in Data
    Get_Range_Dimensions Range(sDataRange), _
        lRowData, lRowsData, lColData, lColsData
    
    Dim lRowTarget As Long          'First Row in Target
    Dim lColTarget As Long          'First Column in Target
    Dim lRowsTarget As Long         'Total Rows in Target
    Dim lColsTarget As Long         'Total Columns in Target
    Get_Range_Dimensions rngTarget, _
        lRowTarget, lRowsTarget, lColTarget, lColsTarget
    
    With frmProgress                'Show progress bar
        .pCaption = "Checking for Errors"
        .pPct = 0
        If lRowsTarget > 1 Then .Show False
    End With
                
   'Loop through all rows
    For lRow = lRowTarget To lRowTarget + lRowsTarget - 1
    
       'Update Progress Bar
        If frmProgress.Visible Then _
            frmProgress.pPct = (lRow - lRowTarget) / lRowsTarget
                
       'Only process Adds or Changes
        If InStr(1, "AC", Cells(lRow, lColACD)) > 0 Then
            Cells(lRow, lColERRORS) = ""    'Clear Error message
            
           'Loop through all cells in this row
            For lCol = lColTarget To lColTarget + lColsTarget - 1
                
               'Don't check locked cells.  The user can't change them
                If Not Cells(lRow, lCol).Locked And _
                   Cells(lRow, lCol).Interior.Color <> CellChecked Then
                    Cell_Unlock Cells(lRow, lCol)   'Clear red fill
                    
                   'Select method for validating based on column header
                    Select Case Cells(lRowData, lCol)
                    
                    'NOTE TO PGMR: Add custom validation code here
                    'NOTE TO PGMR: End modifications
 
                        Case Else   
                            Check_Entry = _
                                Check_For_Normal_Entry_Errors( _
                                    Me.Name, _
                                    sDataFieldDefinitions, _
                                    lCol - lColData + 1, _
                                    Cells(lRow, lCol), _
                                    Cells(lRow, lColERRORS))
                    End Select
                    
                End If
            Next lCol
        End If
    Next lRow
    
ErrHandler:
    
    If Err.Number <> 0 Then MsgBox _
        "Check_Entry - Error#" & Err.Number & vbCrLf & Err.Description, _
        vbCritical, "Error", Err.HelpFile, Err.HelpContext
    If frmProgress.Visible Then frmProgress.Hide
    On Error Resume Next
    Settings "Restore"                  'Restore previous settings
    On Error GoTo 0
 
End Function
 
 
 
Function Get_Range_Dimensions( _
            Range As Range, _
            StartRow As Long, TotalRows As Long, _
            StartCol As Long, TotalCols As Long) As Boolean
  
'   Description:Returns basic dimensions of a range
 
'   Parameters: Range       Range for which dimensions are desired
'               StartRow    Upper left row of the range
'               TotalRows   Number of rows in the range
'               StartCol    Upper left column of the range
'               TotalCols   Number of columns in the range
 
'   Example:    Get_Range_Dimentions Range("Data"), _
                    lRow, lRows, lCol, lCols
 
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming
    
    On Error GoTo ErrHandler            '
    Get_Range_Dimensions = Failure      'Assume the worst
        
    StartRow = Range.Row
    TotalRows = Range.Rows.Count
    StartCol = Range.Column
    TotalCols = Range.Columns.Count
    
    Get_Range_Dimensions = Success      'Successful finish
 
ErrHandler:
    
    If Err.Number <> 0 Then MsgBox _
        "Get_Range_Dimensions - Error#" & Err.Number & vbCrLf & _
        Err.Description, vbCritical, "Error", Err.HelpFile, Err.HelpContext
    On Error GoTo 0
 
End Function
 


July 6, 2010  9:44 PM

Check Entry – Dealing with Field Level Exceptions

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker

We’re just about finished dealing with the Check_For_Normal_Entry_Errors.  It uses one routine we haven’t discussed, Cust_Edit

Cust_Edit handles any field level validation that Check_For_Normal_Entry_Errors can’t.  Usually, this is a database lookup, but it can encompass any non-‘standard’ validation – and that’s the problem with it.

Cust_Edit is really only a shell.  It is a place for you to write your own validation routines.  Many times I don’t need to modify Cust_Edit at all because the ‘standard’ edits are just fine.  Other times I have to plug in a simple database lookup for which I provide a template in the comments.  On very rare occasions, I have to write something truly unique.   Because Cust_Edit is something you modify, I can’t really explain much about it.  I can only give some guidance on how to plug your code in.  And that’s the beauty of it.

Cust_Edit is one of the few places where modifications are likely at all.  By having this shell prepared, you know exactly where to modify code, and best of all, where not to. Leave Check_For_Normal_Entry_Errors alone.  Ignore it.  Never think about it.  Put your custom validation rules in Cust_Edit only and nowhere else. 

Cust_Edit is called when V.Type (validation type) in Fields Definition Table equals “CUST” (custom) for a particular field.  The specific validation rule is held in the V.Table column.  That value is placed into sRoutine.  Plug your code after the Select Case sRoutine line.  To code the rule, create a Case Is = “<rule name>” line where “<rule name>” is the same as the value in V.Table for that field.  What you code after that is whatever is required for your particular rule.

Cust_Edit returns a comma delimited string with each value surrounded by double quotes like: “”VA”,”Virginia”” where “VA” is the code for “Virginia”.  In the templates and examples, it is assumed you want the description to display next to the code.  If you don’t, make sure only the code (surrounded by double quotes) is returned by Cust_Edit.

Since the most often case for custom validations is a database lookup, I have provided a template for that in the comments and two examples after the routine.  Copy the code for Cust_Edit into your worksheet where entries are made.  Don’t copy the examples. 

There’s one last thing I want to cover with you on this routine, and that is the odd parameter bUsePopUpbUsePopUp is a boolean (flag) variable.  If set to TRUE, Cust_Edit allows the user to select a value from the database using frmSelect.  When Cust_Edit is called from Check_For_Normal_Entry_Errors, bUsePopUp is always set to FALSE.  But Cust_Edit is also called by Set_Normal_Entry_Defaults.  We haven’t discussed Set_Normal_Entry_Defaults yet.  It is very similar to Check_For_Normal_Entry_Errors in that it can validate entries.  It is very different from Check_For_Normal_Entry_Errors in that it allows errors to be fixed.  Each routine has its place.  One cannot replace the other.   bUsePopUp allows Cust_Edit to serve them both.

Here is the code:

‘ ** Heavy modifications are likely here

 

Function Cust_Edit(sRoutine As String, rngCell As Range, _

                   bUsePopUp As Boolean) As Variant

 

   Description:Custom Validation Routine – Handles validations _

                that can’t be handled by default methods

 

   Parameters: sRoutine    Identifies the section of code to use

               rngCell     Cell being validated

               bUsePopUp   If True, user can select values from a list

 

   Example:    bResult = Cust_Edit(“Products”, Cell(lRow, 2), True)

 

     Date   Init Modification

   01/01/01 CWH  Initial Programming

 

    On Error GoTo ErrHandler   

    Cust_Edit = Null            ‘Assume the worst

       

    Dim v As Variant            ‘Generic Variant

    Dim l As Long               ‘Generic Numeric Variable

    Dim sSQL As String          ‘SQL String

    Dim sSQLCode As String      ‘SQL string for Codes/IDs

    Dim sSQLDesc As String      ‘SQL string for Descriptions/Names

    Dim sCode As String         ‘Code/ID field name

    Dim sDesc As String         ‘Desc/Name field name

    Dim sFile As String         ‘Table/File to search

   

   ‘Open the default connection

    If cn Is Nothing Then SQLConnection cn, sConnect

   

    Select Case sRoutine

       

        ‘Looking for a match in a database table/file

       

        ‘Step 1 – Look for Code’s Description in validated entries _

                  (it could only get there if code is good)

                 XL_Lookup(Range, _

                            Column in Range to return, _

                            Column to Range look in, _

                            Value to look for)

       

        ‘Step 2 – If not in worksheets, look in database

                 DB_Lookup(Value to look for, _

                            Table to look in, _

                            SQL to select Codes/IDs by, _

                            SQL to select Desc./Names by, _

                            Label for Code in frmPrompt, _

                            Label for Description in frmPrompt, _

                            Connection string, _

                            Connection Object, _

                            Popup(frmPrompt) is allowed flag)

               

                    

    End Select

 

ErrHandler:

   

    If Err.Number <> 0 Then MsgBox _

        “Cust_Edit – Error#” & Err.Number & vbCrLf & _

        Err.Description, vbCritical, “Error”, Err.HelpFile, Err.HelpContext

    On Error GoTo 0

 

End Function

 

 

 

 

 

Case Is = “Products”    ‘Access Example

    ‘Step 1 – Look for Code’s Description in validated entries

     v = XL_Lookup(Range(“Data”), “Name”, “Code”, rngCell)

     If v > “” Then v = “””” & rngCell.Text & “””, “”” & v & “”””

   

   ‘Step 2 – If not in worksheets, look in database

    If Left(rngCell.Text, 1) = “?” Or IsNull(v) Or IsEmpty(v) Then

        sCode = “[Product Code]”

        sDesc = “[Product Name]”

        sTable = “Products”

        sSQL = _

            “Select  Top 100 ” & sCode & “, ” & sDesc & ” ” & vbCr & _

            “From    ” & sTable & ” ” & vbCr

        sSQLCode = sSQL & _

            “Where    uCase(” & sCode & “) like ‘?%’ ” & vbCr & _

            “Order by ” & sCode & ” “

        sSQLDesc = sSQL & _

            “Where    uCase(” & sDesc & “) like ‘%?%’ ” & vbCr & _

            “Order by ” & sDesc & ” “

        v = DB_Lookup(rngCell.Text, sSQLCode, sSQLDesc, _

                      “Code”, “Name”, bUsePopUp, sConnect, cn)

    End If

    If Not IsNull(v) And Not IsEmpty(v) Then Cust_Edit = v

       

Case Is = “CUSTMAST”    ‘DB2 Example

    ‘Step 1 – Look for Code’s Description in validated entries

     v = XL_Lookup(Range(“Data”), “Name”, “Code”, rngCell)

     If v > “” Then v = “””” & rngCell.Text & “””, “”” & v & “”””

   

   ‘Step 2 – If not in worksheets, look in database

    If Left(rngCell.Text, 1) = “?” Or IsNull(v) Or IsEmpty(v) Then

        sCode = “CUCODE”

        sDesc = “CUNAME”

        sTable = “CUSTMAST”

        sSQL = _

            “Select  ” & sCode & “, ” & sDesc & ” ” & vbCr & _

            “From    ” & sTable & ” ” & vbCr

        sSQLCode = sSQL & _

            “Where    uCase(” & sCode & “) like ‘?%’ ” & vbCr & _

            “Order by ” & sCode & ” ” & vbCr & _

            “Fetch First 100 Rows Only “

        sSQLDesc = sSQL & _

            “Where    uCase(” & sDesc & “) like ‘%?%’ ” & vbCr & _

            “Order by ” & sDesc & ” ” & vbCr & _

            “Fetch First 100 Rows Only “

        v = DB_Lookup(rngCell.Text, sSQLCode, sSQLDesc, _

                      “Code”, “Name”, bUsePopUp, sConnect, cn)

    End If

    If Not IsNull(v) And Not IsEmpty(v) Then Cust_Edit = v

 

 

 

 

 

 

 

 

 

 

 


July 1, 2010  9:32 PM

Check Entry – Marking Cells as having passed or failed

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker

The last post talked about a generic validation routine.  That routine requires some functions that I will provide code for in this post.

These functions convey to users and other routines which cells: can change; have changed, have passed validation; or have failed.  Users need this information to know what can be changed and what needs fixing.  The other routines need this information to know what has changed and needs checking, and what has passed validation and doesn’t need to be checked again.  To convey this information we use a simple technique, color. 

The colors I use are culturally well suited for my audience: pale yellow for changed but not yet verified; pale green for passed validation; and pale red for needs fixing.  You can easily change the colors to suit your preferences and culture.

In addition, I’ve included another routine that is referenced in the prior post, Fields_Field_Column.  That routine finds a string within curly brackets.  The curly brackets are used in the Fields Definition file when the “XLT” (Excel Type Table) validation rule is indicated in the “V.Type” column.  Before we explain much else, let’s look at an example of the XLT rule in action.  In this example, suppose we have an Excel Range called “States” containing Country Codes, associated State Codes, and the name of the states like this small sample:

States Table      

Type Code Description
US VT Vermont
US WA Washington 
US WI Wisconsin
US WV West Virginia
US WY Wyoming
CA AB Alberta
CA BC British Columbia
CA MB Manitoba

When the country is “US” we need to restrict State Codes to those for which the “Type” is “US”.  Now let’s also suppose we have entries for sales by state/province that looked something like this:

Entries            

Country State/Province Date Amount
US VT 09/11/2010 10,231.00
US WA 09/11/2010 25,454.45
US WI 09/11/2010 15,132.22

We can tell Check_For_Normal_Entry_Errors to impose this rule by coding the Fields Definition Table like this:

“Heading” = “State/Province”
“V.Type” = “XLT”
“V.Table” =”States {Country}” 

This basically says, make sure entries for the “State/Province” column are in the “States” table where the States Table “Type” equals the “Country” column for each entry.

Twenty/Twenty hind sight tells me I should have named the routine something far different.  At some point in the future I will.  But there’s nothing stopping you from naming it something that makes more sense to you.  You’ve got all of the code.  Do what you want with it. 

   

Function Fields_Field_Column(sFields As String, sString As String, _
                             Optional iStart As Integer) As Long

‘   Description:Determine which field in the “Fields Definition Table” is
‘               indicated by a value in curly brackets

‘   Parameters: sFields     The name of the “Fields Definition Table” range
‘               sString     A string containing the value in curly brackets
‘               iStart      [Optional: assumed to be 1] Which character to
‘                           start search for curly bracket
‘   Example:    lCol = Fields_Field_Column(“Fields”, “Products {Category}”)

‘     Date   Init Modification
‘   04/05/10 CWH  Initial Programming

    On Error GoTo ErrHandler           
    Fields_Field_Column = 0             ‘Assume the Worst

    Dim iBeg As Integer                 ‘Start of sub-string
    Dim iEnd As Integer                 ‘End of sub-string
    Dim s As String                     ‘Sub String
    Dim lRow As Long                    ‘Current Row Number
    Dim lRows As Long                   ‘Number of rows in sFields
        lRows = Range(sFields).Rows.Count
    Dim lColFld As Long
        lColFld = FieldColumn(“Field”, sFields)
    Dim lColHdg As Long
        lColHdg = FieldColumn(“Heading”, sFields)
   
    If iStart <= 0 Then iStart = 1
   
    ‘Search for left curly bracket – designating start of a field
     iBeg = InStr(iStart, sString, “{“)
     If iBeg > 0 Then
        iEnd = InStr(iStart, sString, “}”)
       ‘s equals name of a field, or heading in the Fields Table
        s = Mid(sString, iBeg + 1, iEnd – 1 – iBeg)
       ‘Search Fields Table to determine field # referenced
        With Range(sFields)
            For lRow = 2 To lRows
                If Trim(.Cells(lRow, lColFld)) = s Or _
                   Trim(.Cells(lRow, lColHdg)) = s Then
                    Fields_Field_Column = lRow – 1
                    Exit For
                End If
            Next lRow
        End With
    End If
   
ErrHandler:
   
    If Err.Number <> 0 Then MsgBox _
        “Fields_Field_Column – Error#” & Err.Number & vbCrLf & _
        Err.Description, vbCritical, “Error”, Err.HelpFile, Err.HelpContext

    On Error GoTo 0

End Function

 

Option Explicit

‘Color codes for cell validation states
Global Const CellUnchecked = 11862015   ‘Light Yellow
Global Const FontUnchecked = 8388608    ‘Dark Blue

Global Const CellChecked = 13434828     ‘Light Green
Global Const FontChecked = 8388608      ‘Dark Blue

Global Const CellError = 10066431       ‘Light Red
Global Const FontError = 0              ‘Black

Global Const CellLocked = 16777215      ‘White
Global Const FontLocked = 128           ‘Maroon

 

 

 

Function Cell_Lock(rngRange As Range) As Boolean

‘   Description:Locks cells to prevent user modifications

‘   Parameters: rngRange    Cell to lock
‘   Example:    bResult = Cell_Lock(“A4″)

‘     Date   Init Modification
‘   01/01/01 CWH  Initial Programming
   
    Cell_Lock = Failure                
‘Assume the Worst
   
On Error GoTo ErrHandler
   
   
Dim Cell As Range
   
   
For Each Cell In rngRange
       
With Cell
            .Locked = True
            .Interior.Color = CellLocked
            .Font.Color = FontLocked
       
End With
   
Next
      
    Cell_Lock = Success

ErrHandler:
   
    If
Err.Number <> 0 Then MsgBox _
        “Cell_Lock – Error#” & Err.Number & vbCrLf & _
        Err.Description, vbCritical, “Error”, Err.HelpFile, Err.HelpContext
    On Error GoTo 0

End Function

 

Function Cell_Unlock(rngRange As Range) As Boolean

‘   Description:Opens cells for entries & marks as unchecked

‘   Parameters: rngRange    Cell to unlock
‘   Example:    bResult = Cell_UnLock(“A4″)

‘     Date   Init Modification
‘   01/01/01 CWH  Initial Programming

   
    Cell_Unlock = Failure         
‘Assume the Worst
   
On Error GoTo ErrHandler
   
   
Dim Cell As Range
   
   
For Each Cell In rngRange
       
With Cell
            .Locked = False
            .Interior.Color = CellUnchecked
            .Font.Color = FontUnchecked
       
End With
   
Next
   
    Cell_Unlock = Success

ErrHandler:
   
    If
Err.Number <> 0 Then MsgBox _
        “Cell_Unlock – Error#” & Err.Number & vbCrLf & _
        Err.Description, vbCritical, “Error”, Err.HelpFile, Err.HelpContext
    On Error GoTo 0

End Function

 


Function Cell_UnChecked(rngRange As Range) As Boolean

‘   Description:Marks a cell as unchecked
‘               Will not open locked cells

‘   Parameters: rngRange    Cell to unlock
‘   Example:    bResult = Cell_UnChecked(“A4″)

‘     Date   Init Modification
‘   01/01/01 CWH  Initial Programming
   
    Cell_UnChecked = Failure       
‘Assume the Worst
   
On Error GoTo ErrHandler
   
   
Dim Cell As Range
   
   
For Each Cell In rngRange
       
With Cell
            If Not .Locked Then
                .Interior.Color = CellUnchecked
                .Font.Color = FontUnchecked
            End If
       
End With
   
Next
   
    Cell_UnChecked = Success

ErrHandler:
   
    If
Err.Number <> 0 Then MsgBox _
        “Cell_UnChecked – Error#” & Err.Number & vbCrLf & _
        Err.Description, vbCritical, “Error”, Err.HelpFile, Err.HelpContext
    On Error GoTo 0

End Function

 

Function Cell_Error(rngCell As Range, Optional rngMsg As Range, _
                    Optional sMsg As String) As Boolean

‘   Description:Marks a single cell as in error (failed Check_Entry)

‘   Parameters: rngCell Cell containing invalid entry
‘               rngMsg  Cell that can display error messages
‘               sMsg    Error description
‘   Example:    bResult = Cell_Error(“A4″, “H4″, _
                    “Customer number not found in the Customer Master”)

‘     Date   Init Modification
‘   01/01/01 CWH  Initial Programming
   
    Cell_Error = Failure         
‘Assume the Worst
   
On Error GoTo ErrHandler
   
   
With rngCell
        .Locked = False
        .Interior.Color = CellError
        .Font.Color = FontError
      
‘Add Error message
       
If Trim(sMsg) > “” Then _
            rngMsg = rngMsg & IIf(Len(rngMsg) > 0, vbLf, “”) & sMsg
   
End With

    Cell_Error = Success

ErrHandler:
   
    If
Err.Number <> 0 Then MsgBox _
        “Cell_Error – Error#” & Err.Number & vbCrLf & _
        Err.Description, vbCritical, “Error”, Err.HelpFile, Err.HelpContext
    On Error GoTo 0

End Function

 

Function Cell_Checked(rngRange As Range) As Boolean

‘   Description:Marks a cell as validated
‘               Will not open locked cells

‘   Parameters: rngCell Cell containing validated entry

‘   Example:    bResult = Cell_Checked(“A4″)

‘     Date   Init Modification
‘   01/01/01 CWH  Initial Programming
   
    Cell_Checked = Failure         
‘Assume the Worst
   
On Error GoTo ErrHandler
   
   
Dim Cell As Range
   
   
For Each Cell In rngRange
       
With Cell
           
If Not .Locked Then
                .Interior.Color = CellChecked
                .Font.Color = FontChecked
           
End If
       
End With
   
Next

    Cell_Checked = Success

ErrHandler:
   
    If
Err.Number <> 0 Then MsgBox _
        “Cell_Checked – Error#” & Err.Number & vbCrLf & _
        Err.Description, vbCritical, “Error”, Err.HelpFile, Err.HelpContext
    On Error GoTo 0

End Function

 

 

 

 

 

 


June 30, 2010  9:30 PM

Check Entry – Common Validations

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker

Today’s post is about a routine I call Check_For_Normal_Entry_Errors.  In my opinion, the toughest part of coding is checking for entry errors because just knowing what good values look like isn’t good enough.  You also need to anticipate anything a user might do even though it may make no sense for anyone to do whatever that might be.  If you’ve been coding end user entry applications for any length of time, you know exactly what I mean.  I’m not going to tell you that I’ve solved that riddle, but I do offer some basic validation routines that fit many common entry problems.  I also offer the source code so you can fill in the gaps I have left.

Check_For_Normal_Entry_Errors is meant to be a function that is never modified for a specific entry problem.  It is for ‘general’ entry problems and for that reason is placed in modTableUpdateCheck_For_Normal_Entry_Errors works in concert with Check_Entry which is a routine meant to be modified for a particular worksheet’s specific validation needs.  That routine may have to be modified often; but, not everytime.  In the example we are building, we won’t need to modify it.  Check_For_Normal_Entry_Errors handles everything we need.

Check_For_Normal_Entry_Errors receives a cell and finds which validation rule should  be applied to it from the Fields Definition table discussed in several prior posts.  The rules that can be specified in the Fields Definition table that Check_For_Normal_Entry_Errors can apply to the cell are to make sure:

  • Required entries are not empty
  • The ACD column only contains the values “A”, “C”, “D”, or “X” (Add, Change, Delete or eXisting)
  • Date fields contain valid dates (NOTE: This does not check to make sure dates are future or past, workdays or not, etc.)
  • Flag fields contain “Y” or “N” (Yes or No)
  • Numeric fields contain numbers only
  • Code fields are limited to values in an Excel Code Table
  • Type Code Fields are limited to values that match a “Type” value in the entry and a “Code” value in an Excel Type Table
  • Text fields are limited to a designated number of characters
  • Custom Edits/Validations are handled by the worksheet’s Check_Entry routine

There are a few support routines here that I have not yet covered.  They are small routines that mark cells in error or as having passed our validation rules.  Those will be the subject of our next post.

One last note, this routine will never, and should never try to correct anything.  ALL this routine does is determine if an entry is valid or not.  Now that may seem odd because I spent so much time on frmSelect which is all about helping users correct bad entries.   I included frmSelect because it is called by routines Check_For_Normal_Entry_Errors uses, but Check_For_Normal_Entry_Errors tells those routines to NOT use frmSelect for that purpose.  Those routines serve multiple masters and when they serve Set_Entry_Defaults, frmSelect will come into play.  Just keep in mind that there are times when you want to let the user know their entry is wrong and help them fix it, and times when ALL you want to know is if the entry is ready for posting.  Those functions have a lot of overlap, but they MUST be independent of each other.

As always, I believe the code’s documentation explains how the routines works so I’ll not duplicate what’s in the code.  Here is the code. 

Function Check_For_Normal_Entry_Errors( _
		sWorksheet As String, sFields As String, lField As Long, _
                  rngCell As Range, rngMsg As Range) As Boolean
'   Description:Checks a cell against the most common validation rules.
'               Place special rules in Worksheet's Check_Entry routine
'   Parameters: sWorksheet  Worksheet containing data AND Check_Entry routine
'               sFields     Range name containing field descriptions
'               lField      Relative row (-1) within sFields of field to check
'               rngCell     Cell being checked
'               rngMsg      Cell in which to put any error messages
                           
'   Example:    bResult = Check_For_Normal_Entry_Errors( _
                              Me.Name, sDetailFields, _
                              lCol - lColData + 1, _
                              Cells(lRow, lCol), _
                              Cells(lRow, lColNote))
'     Date   Init Modification
'   01/12/06 CWH  Initial Programming
    On Error GoTo ErrHandler           
    Check_For_Normal_Entry_Errors = Success     'Assume the best
       
    Dim s As String     'Generic String Variable
    Dim t As String     'Type for a code
    Dim v As Variant    'Generic Variant Result
      
    lField = lField + 1
    With Range(sFields)
   
        If UCase(.Cells(lField, lColReq)) = "Y" And Trim(rngCell) <= "" Then
            Cell_Error rngCell, rngMsg, .Cells(lField, lColHdg) & _
                " is required"
            Check_For_Normal_Entry_Errors = Failure
       
        ElseIf Trim(rngCell) > "" Then
       
            Select Case UCase(.Cells(lField, lColVTyp))
           
               'eXisting, Added, Changed, Deleted record indicator
                Case "ACD"
                    If InStr(1, "ACDX", rngCell) <> 0 Then
                        Cell_Checked rngCell
                    Else
                        Cell_Error rngCell, rngMsg, .Cells(lField, lColHdg) & _
                            "In ACD: A=Add, C=Change or D=Delete"
                        Check_For_Normal_Entry_Errors = Failure
                    End If
               
               'Dates
                Case Is = "DATE"
                    If IsDate(rngCell) Then
                        Cell_Checked rngCell
                    Else
                        Cell_Error rngCell, rngMsg, .Cells(lField, lColHdg) & _
                            " must be a valid date and time"
                        Check_For_Normal_Entry_Errors = Failure
                    End If
                   
               'Yes or No flags
                Case Is = "YORN"
                    If InStr(1, "YyNn", rngCell) <> 0 Then
                        Cell_Checked rngCell
                    Else
                        Cell_Error rngCell, rngMsg, .Cells(lField, lColHdg) & _
                            " must be Y (Yes) or N (No)"
                        Check_For_Normal_Entry_Errors = Failure
                    End If
               
               'Numeric Values
                Case Is = "#", "$", "NUMBER"
                    If IsNumeric(rngCell) Then
                        Cell_Checked rngCell
                    Else
                        Cell_Error rngCell, rngMsg, .Cells(lField, lColHdg) & _
                            " must be numeric"
                        Check_For_Normal_Entry_Errors = Failure
                    End If
               
               'Custom Edits/Validation rules
                Case Is = "CUST"                   
                    s = .Cells(lField, lColVTbl)    'Get rule Name
                    v = Worksheets(sWorksheet).Cust_Edit(s, rngCell, False)
                    If Not IsNull(v) Then
                        Parse_SQL_Result CStr(v), rngCell.Row, rngCell.Column
                        Cell_Checked rngCell
                    Else
                        Cell_Error rngCell, rngMsg, .Cells(lField, lColHdg) & _
                            " is not valid"
                        Check_For_Normal_Entry_Errors = Failure
                    End If
               
               'Excel Code Tables
                Case Is = "XLC"
                    s = .Cells(lField, lColVTbl)    'Get XL Table Name
                    v = XL_Lookup(Range(s), "Code", "Code", rngCell.Text)
                    If Not IsNull(v) Then
                        Cell_Checked rngCell
                    Else
                        Cell_Error rngCell, rngMsg, .Cells(lField, lColHdg) & _
                            " is not valid"
                        Check_For_Normal_Entry_Errors = Failure
                    End If
               
               'Excel Type Tables
                Case Is = "XLT"
                   'Excel Table holding Types and Codes

                    s = .Cells(lField, lColVTbl)       
                   'The Type value within the Entry to restrict codes by                    
                    t = Cells(rngCell.Row, Fields_Field_Column(sFields, s))
                    s = Trim(Left(s, InStr(1, s, "{") - 1))                
                    v = XL_Lookup(Range(s), "Code", "Code", _
                                  rngCell.Text, "Type", t)
                    If Not IsNull(v) Then
                        Cell_Checked rngCell
                    Else
                        Cell_Error rngCell, rngMsg, _
                            .Cells(lField, lColHdg) & _
                            " is not valid for code " & rngCell.Cells(1, 0)
                        Check_For_Normal_Entry_Errors = Failure
                    End If
                               
               'Limits on the number of characters in a text field
                Case Else
                    v = Val(.Cells(lField, lColVTyp))
                    If v > 1 Then
                        If Len(rngCell) <= v Then
                            Cell_Checked rngCell
                        Else
                            Cell_Error rngCell, rngMsg, _
                                .Cells(lField, lColHdg) & _
                                " must be " & v & "characters or less"
                            Check_For_Normal_Entry_Errors = Failure
                        End If
                    End If
                   
            End Select
        End If
    End With
ErrHandler:
   
    If Err.Number <> 0 Then
        Check_For_Normal_Entry_Errors = Failure
        Cell_Error rngCell, rngMsg, rngCell.Cells(lField, lColHdg) & _
             Err.Description
        MsgBox _
            "Check_For_Normal_Entry_Errors - Error#" & Err.Number & vbCrLf _
             & Err.Description, vbCritical, "Error", Err.HelpFile, _
             Err.HelpContext
        End If
    On Error GoTo 0
End Function


June 25, 2010  3:54 PM

Check Entry – Form Select – Code

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker

Today we add the code to frmSelect (See: frmSelect Visual Elements for what this form looks like, or frmSelect Theory to see how it works).  This code must be added to the form.  If you’re not sure how to do that, watch the video in frmSelect Visual Elements and at the tale end is where, in the Project Explorer you’ll see me right clicking on frmSelect and left clicking on “View Code.”  In the Code View Window is where you paste all the code provided. 

There’s a good bit of code but all you have to do is copy and paste it (with perhaps a tweak or two because this blog doesn’t always paste code nicely into the VBE).  And the really good news is that once you’ve saved this form, you’ll never have to change it again.  It has worked well over all master files or code files I’ve seen without any modifications. 

When finished, be sure to save your work.  You may also want to save the form as a separate object so you can import it into other Excel spreadsheets easily.  To export the form, in the Project Explorer right click on frmSelect and left clicked on “Export File…”  Here is the code:

 

Option Explicit

'   Name:   frmSelect
'   Purpose:Help user pick something by Code/ID/# or Description
'     Date   Init Modification
'   01/12/06 CWH  Initial Programming
'   Examples:
'   Pick State from an XL "Code" table
'   vResult = frmSelect.Pick_Code("States")
'   Pick Account from an XL "Type" table
'   vResult = frmSelect.Pick_Type("Accounts", "Credit")
'   See Methods Pick_Code and Pick_Type at the end of this form. _
    These can be used as is or copied and customized in a module
'   Set (Write Only) Property Variables
    Dim sConnect As String  'See property pConnect
    Dim sSQLCode As String  'See property pSQLCode
    Dim sSQLDesc As String  'See property pSQLDesc
   
    Dim sDesc As String     'See property pDftDesc
    Dim sCode As String     'See property pDftCode
   
'   Get(Read Only) Property Variables
    Dim bOK As Boolean      'See property pOK
'Begin Properties
'   Title Bar Text (Optional)
Public Property Let pTitle(sString As String)
    Me.Caption = sString
End Property
'   Connect - ODBC connection string (Required)
Public Property Let pConnect(sString As String)
    sConnect = sString
End Property
'   Code: These properties relate to the "Code" value
Public Property Let pCode(sString As String)    'Set value
    sCode = sString
End Property
Public Property Get pCode() As String           'Get value
    pCode = sCode
End Property
Public Property Let pLblCode(sString As String) 'Label for entry box
    lblCode.Caption = sString
End Property
Public Property Let pDftCode(sString As String) 'Default value
    txtCode.Text = sString
End Property
Public Property Let pSQLCode(sString As String) 'SQL Search String
'   The String must contain a valid SQL select statement with a "?"
'   to indicate where to substitute the txtID.text
    sSQLCode = sString
End Property
'   Description: These properties relate to teh "Description" value
Public Property Let pDesc(sString As String)    'Set value
    sDesc = sString
End Property
Public Property Get pDesc() As String           'Get value
    pDesc = sDesc
End Property
Public Property Let pLblDesc(sString As String) 'Label for entry box
    lblDesc.Caption = sString
End Property
Public Property Let pDftDesc(sString As String) 'Default value
    txtDesc.Text = sString
End Property
Public Property Let pSQLDesc(sString As String) 'SQL search string
'   The String must contain a valid SQL select statement with a "?"
'   to indicate where to substitute the txtDesc.text
    sSQLDesc = sString
End Property
'   True if the OK button was clicked
Public Property Get pOK() As Boolean
    pOK = bOK
End Property
 
'Begin Event Handlers
'   Exit Button
Private Sub cmdExit_Click() 'Exit Click
    Me.Hide
End Sub
'   OK Button
Private Sub cmdOK_Click()   'OK Click
    Dim i As Integer
    Dim sSQL As String
    Dim bfound As Boolean
   
    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 = ""
      
'   If the user changed the ID then create the SQL search string
    If txtCode <> sCode Then
        bfound = False
        If lstList.Visible Then
            For i = 0 To lstList.ListCount - 1
                If Trim(UCase(txtCode)) = _
                   Trim(UCase(lstList.List(i, 0))) Then
                    lstList.ListIndex = i
                    bfound = True
                    Exit For
                End If
            Next i
        End If
        If Not bfound Then
            sCode = txtCode
            txtDesc = ""
            sDesc = ""
            sSQL = InsertSQLVariable(sSQLCode, Trim(UCase(sCode)))
            txtCode.SetFocus
        End If
    End If
'   If user changed Description then create  SQL search string _
    (this overrides ID changes)
    If txtDesc <> sDesc Then
        sDesc = txtDesc
        txtCode = ""
        sCode = ""
        sSQL = InsertSQLVariable(sSQLDesc, Trim(UCase(sDesc)))
        txtDesc.SetFocus
    End If
'   If an SQL string was created above then search database
    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.Open sSQL, cn
   
        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
                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
       
'   If no SQL string was created (because user didn't change anything) _
    then did user select anything?
    Else
'       If anything was selected, were done!
        If lstList.Visible And lstList.Value > "" Then
            sCode = lstList.Value
            sDesc = lstList.List(lstList.ListIndex, 1)
            bOK = True
            Me.Hide
        End If
       
    End If
               
    On Error GoTo 0
    Exit Sub
   
ErrHandler:
               
    If cn.Errors.Count = 0 Then
        MsgBox "cmdOK_Click Error#" & Err.Number & vbCrLf & Err.Description, _
            vbCritical, "Error in cmdOK_Click", Err.HelpFile, Err.HelpContext
    Else
        For i = 0 To cn.Errors.Count - 1
            MsgBox "Error number: " & cn.Errors(i).Number & vbCr & _
               cn.Errors(i).Description, vbCritical, "Error in cmdOK_Click", _
               cn.Errors(i).HelpFile, cn.Errors(i).HelpContext
        Next i
    End If
       
    rs.Close
    cn.Close
  
End Sub
'   Double click on list selects the code and exits
Private Sub lstList_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    sCode = lstList.Value
    txtCode = sCode
    cmdOK_Click
End Sub
'   Activate form
Private Sub UserForm_Activate()
   'Center form on screen
    Me.Left = Application.Left + Application.Width / 2 - Me.Width / 2
    bOK = False		'Assume the worst
    lstList.Visible = False
   'Set Column Widths of lstList to match the input text boxes
    lstList.ColumnWidths = txtCode.Width & ";" & txtDesc.Width
    sCode = ""		'Clear Text Boxes
    sDesc = ""
   'Give the users some instructions
    lblMessage = "Wildcard characters: '_'(underscore) " & _
                 "replaces just 1 character  '%' replaces many"
    cmdOK_Click		'List whatever is possible to list
End Sub
 
'Begin 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
 
'   Pick a code from an Excel code table in the active spreadsheet
'   Table must have two columns: Code and Description
'   Where:
'       Code        unique identifier (ex. "VA" or "MD")
'       Description expanded text for the Code (ex. "Virginia" or "Maryland")
Public Function Pick_Code(sCodeTable As String) As Variant
  
   Pick_Code = Null
  
   With frmSelect
        .pConnect = _
            "DBQ=" & ActiveWorkbook.Path & "\" & ActiveWorkbook.Name & ";" & _
            "Driver={Microsoft Excel Driver (*.xls)};"
        .pLblCode = "Code"
        .pLblDesc = "Description"
        .pTitle = "Select Code from " & sCodeTable
        .pCode = ""
        .pDftCode = " "
        .pSQLCode = _
            "Select T.Code as CODE, T.Description as NAME " & _
            "From " & sCodeTable & " T " & _
            "Where Ucase(T.Code) Like '?%' " & _
            "Order by T.Code "
        .pSQLDesc = _
            "Select T.Code as CODE, T.Description as NAME " & _
            "From " & sCodeTable & " T " & _
            "Where Ucase(T.Description) Like '%?%' " & _
            "Order by T.Description "
        .Show
        Do While .Visible
            DoEvents
        Loop
        If .pOK Then   'The OK button was used to exit
            Pick_Code = .pCode
        End If
   End With
End Function
 
'   Pick a Type from an Excel code table in the active spreadsheet
'   Table must have three columns: Code, Type, & Description
'   Where:
'       Type        Major catagory (Country ex. "USA" or "Mexico")
'       Code        Individual element (State w/in Coutnry ex. "VA", or "MD")
'       Description Expanded text for Code (ex. "Virginia" or "Maryland")
Public Function Pick_Type(sCodeTable As String, sType As String) As Variant
  
   Pick_Type = Null
  
    With frmSelect
        .pConnect = _
            "DBQ=" & ActiveWorkbook.Path & "\" & ActiveWorkbook.Name & ";" & _
            "Driver={Microsoft Excel Driver (*.xls)};"
        .pLblCode = "Code"
        .pLblDesc = "Description"
        .pTitle = "Select Code of Type " & Trim(sType) & " from " & sCodeTable
        .pCode = ""
        .pDftCode = " "
        .pSQLCode = _
            "Select T.Code as CODE, T.Description as NAME " & _
            "From " & sCodeTable & " T " & _
            "Where Ucase(T.Code) Like '?%' " & _
            "  And Ucase(T.Type) = '" & UCase(sType) & "' " & _
            "Order by T.Code "
        .pSQLDesc = _
            "Select T.Code as CODE, T.Description as NAME " & _
            "From " & sCodeTable & " T " & _
            "Where Ucase(T.Description) Like '%?%' " & _
            "  And Ucase(T.Type) = '" & UCase(sType) & "' " & _
            "Order by T.Description "
      .Show
       Do While .Visible
           DoEvents
       Loop
       If .pOK Then   'The OK button was used to exit
            Pick_Type = .pCode
       End If
   End With
End Function


June 23, 2010  5:43 PM

Check Entry – Form Select – Visual Elements

Craig Hatmaker Craig Hatmaker Profile: Craig Hatmaker
Today we will see how frmSelect is constructed.  This is the basic form with the visual elements labeled.
frmSelect with Labels

frmSelect with Labels

And here is a video that shows how to assemble these elements.
[kml_flashembed movie=”http://www.youtube.com/v/TN0sLLPjcuQ” width=”578″ height=”476″ wmode=”transparent” /]
Now it took a bit of time to create the video so please be understanding as to why this post is so short in terms of words.   In the next post we will wire this up.


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: