Solved

VBA data validation optimization

Posted on 2011-09-28
6
233 Views
Last Modified: 2012-05-12
I am doing a series of data validations. My IF statements are getting pretty tangled up. In the past I have used Select Case for some validation, however, the current routine is moving beyond my knowledge on how to set up in a Select Case Statement.

Basically I am doing several test on multiple columns of cells in a table. I want to see if all of the cell contents are upper case or lower case, test to see if there are special characters in the cell (not shown in the code example below), remove any punctuation marks in the cell containing the City (not shown in the code example below), etc.


My current IF statement is looking like this:

        If (UCase(Range(strColumn & lngCurrentRow).Value) = Range(strColumn & lngCurrentRow).Value) _
        Or (LCase(Range(strColumn & lngCurrentRow).Value) = Range(strColumn & lngCurrentRow).Value) _
        Or (UCase(Range(strAddress2Col & lngCurrentRow).Value) = Range(strAddress2Col & lngCurrentRow).Value) _
        Or (LCase(Range(strAddress2Col & lngCurrentRow).Value) = Range(strAddress2Col & lngCurrentRow).Value) _
        Or (UCase(Range(strCityCol & lngCurrentRow).Value) = Range(strCityCol & lngCurrentRow).Value) _
        Or (LCase(Range(strCityCol & lngCurrentRow).Value) = Range(strCityCol & lngCurrentRow).Value) Then

Open in new window


How can I reformat that in a Select Case or other method to make the code simpler?

0
Comment
Question by:ckelsoe
  • 3
  • 2
6 Comments
 
LVL 1

Expert Comment

by:Cazar
ID: 36720613
Try using a function similar to the following to remove unwanted characters. In the "[A-Z,a-z,0-9, ]" brackets, place the character sets you want to keep in the string.

Function stripNonAlphaNumeric(strText As String) As String

    Dim valid, test As String
    valid = ""
    test = ""

    For i = 1 To Len(strText)
        test = Mid(strText, i, 1)
        If test Like "[A-Z,a-z,0-9, ]" Then
            valid = valid & test
        End If
    Next i
   
    'Return the valid characters
    stripNonAlphaNumeric = valid

End Function
0
 

Author Comment

by:ckelsoe
ID: 36720647
I am not wanting to remove or change the data in the cells. I am highlighting the cells in the sheet that failed validation.

The rules that need to be applied to the data is as follows:

1. An address should be mixed case. If not, color the cell background Yellow for the cell that has failed this test.
2. An address cannot contain special characters. If it does  color the cell background Green for the cell that has failed this test.
3. If the first address cell is blank then color that cell background with Red

In this instance I have columns for Address1, Address2, and City.
0
 
LVL 1

Accepted Solution

by:
Cazar earned 500 total points
ID: 36720711
Functions like the following will accomplish the tests. You'll need to specify the exact character sets you're testing for. Be sure you add a reference for the Regular Expression library.

Function mixedCase(pText As String) As Boolean
    Dim oRegEx As Object
    Set oRegEx = CreateObject("VBScript.RegExp")
    With oRegEx
        .Pattern = "^[a-zA-Z ]+$"
        validCell = .test(pText)
    End With
    Set oRegEx = Nothing
End Function

Function specialCharacters(pText As String) As Boolean
    Dim oRegEx As Object
    Set oRegEx = CreateObject("VBScript.RegExp")
    With oRegEx
        .Pattern = "^[!@#$%&(){}[]\/]+$"
        specialCharacters = .test(pText)
    End With
    Set oRegEx = Nothing
End Function

Here's how you would use the above functions:

If Not mixedCase(text) Then
    Range("A6").Interior.Color = RGB(255,255,0)
End If

If specialCharacters(text) Then
   Range("A6").Interior.Color = RGB(0,100,0)
End If
0
Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

 

Author Comment

by:ckelsoe
ID: 36724275
I applied your code as follows and cannot get it to work:


Sub TestSpecChars()

    Dim strCharsToTest As String

    strCharsToTest = "123 Main Street" ' Should Pass
    strCharsToTest = "#123 Main Street" ' Should Fail
    
    If Not specialCharacters(strCharsToTest) Then
        MsgBox "Failed"
    Else
        MsgBox "Passed"
    End If
End Sub

Sub TestMixed()

    Dim strCharsToTest As String
    
    strCharsToTest = "123 Main Street" ' Should Pass
    'strCharsToTest = "123 MAIN STREET" ' Should Fail
    'strCharsToTest = "123 main street" ' Should Fail
    
    If Not mixedCase(strCharsToTest) Then
        MsgBox "Failed"
    Else
        MsgBox "Passed"
    End If
End Sub

Function mixedCase(pText As String) As Boolean
    Dim oRegEx As Object
    Dim validcell
    Set oRegEx = CreateObject("VBScript.RegExp")
    With oRegEx
        .Pattern = "^[a-zA-Z ]+$"
        validcell = .test(pText)
    End With
    Set oRegEx = Nothing
End Function

Function specialCharacters(pText As String) As Boolean
    Dim oRegEx As Object
    Set oRegEx = CreateObject("VBScript.RegExp")
    With oRegEx
        .Pattern = "^[!@#$%&(){}[]\/]+$"
        specialCharacters = .test(pText)
    End With
    Set oRegEx = Nothing
End Function

Open in new window

I tried referencing both Microsoft VBScript Regular Expressions 1.0 and Microsoft VBScript Regular Expressions 5.5
0
 
LVL 23

Expert Comment

by:Michael74
ID: 36753358
You should not need to add references as the script uses late binding and it worked fine for me

The function mixed case needs a small adjustment to make it work correctly

Just change the word "validCell " to read "mixedCase"

I have attached a test function that worked for me using Cazar's code

Michael
Function mixedCase(pText As String) As Boolean
    Dim oRegEx As Object
    Set oRegEx = CreateObject("VBScript.RegExp")
    With oRegEx
        .Pattern = "^[a-zA-Z ]+$"
        mixedCase = .test(pText)
    End With
    Set oRegEx = Nothing
End Function

Function specialCharacters(pText As String) As Boolean
    Dim oRegEx As Object
    Set oRegEx = CreateObject("VBScript.RegExp")
    With oRegEx
        .Pattern = "^[!@#$%&(){}[]\/]+$"
        specialCharacters = .test(pText)
    End With
    Set oRegEx = Nothing
End Function

Sub test()
   For Each c In Range("A1:A5")
      If mixedCase(c.Text) Then
         c.Interior.Color = vbWhite
      Else
         c.Interior.Color = RGB(255, 255, 0)
      End If
   Next
End Sub

Open in new window

0
 

Author Comment

by:ckelsoe
ID: 36814721
For some reason I am unable to get this to work.
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

How to quickly and accurately populate Word documents with Excel data, charts and images (including Automated Bookmark generation) David Miller (dlmille) Synopsis In this article you’ll learn how to use ExcelToWord! to copy data,charts, shapes …
Freeze panes is an option within all variants of Excel to enable parts of a sheet to remain stationary when the cursor is in another part of the sheet. This is a very useful feature which is overlooked or under used.
Viewers will learn the basics of slicers and timelines for both PivotTables and standard Excel tables in Excel 2013.
The viewer will learn how to create a normally distributed random variable in Excel, use a normal distribution to simulate the return on an investment over a period of years, Create a Monte Carlo simulation using a normal random variable, and calcul…

919 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

21 Experts available now in Live!

Get 1:1 Help Now