Excel VBA Help

[justincaza]

Good evening,
I'm hoping someone can assist in creating a VBA code. I'm fairly new at VBA so my apologies.

I'm looking for VBA that is for 1 column, when a user pastes data or enters it freely, data validation should occur. The data that is pasted or typed must be 8 digits, no special characters or spaces, must have the option for leading zeros. If any data validation fails, can the cells be deleted after a warning message pops.

This is what I have so far and it does not seem to be working. I get multiple warning pops for the same cell and I only need 1. I also cannot figure out the delete cell if failed option or leading zero option. I would also like to confirm the space character is not allowed.

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim Rng As Range
    Dim cell As Range
   
'   See if anything entered/copied into column A
    Set Rng = Intersect(Target, Range("A$5$:A$5000$"))
   
'   Exit if nothing put in watched column
    If Rng Is Nothing Then Exit Sub
   
'   Loop through updated values in watched range
    For Each cell In Rng
'       See if length equals 8
        If Len(cell) <> 8 Then
            Application.EnableEvents = False
            cell.Value = Left(cell, 8)
            Application.EnableEvents = True
            MsgBox cell.Address(0, 0) & " Entry Must Equal 8 Digits", _
                vbOKOnly, "WARNING!"
       
        If Not Intersect(Range("A:A"), Target) Is Nothing Then
                If cell.Value Like "*[0-9]*" Then
                    MsgBox "No Special Characters Allowed" & cell.Address(0, 0) & "!"
                    cell.Select
                End If
        End If
        End If
    Next cell
   
End Sub

 

[Rick Rothstein]

Give this version a try...

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rng As Range
    Dim cell As Range
    
    Set rng = Intersect(Range("A:A"), Target)
    If Not rng Is Nothing Then
        On Error GoTo Escape
        Application.EnableEvents = False
        For Each cell In rng
            If Not cell Like "########" Then
                cell.Interior.Color = vbRed
            Else
                cell.Interior.Color = xlNone
            End If
        Next cell
    End If
    
Continue:
    Application.EnableEvents = True
    Exit Sub
Escape:
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Resume Continue
    
End Sub

 

[justincaza]

Give this version a try...

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rng As Range
    Dim cell As Range
   
    Set rng = Intersect(Range("A:A"), Target)
    If Not rng Is Nothing Then
        On Error GoTo Escape
        Application.EnableEvents = False
        For Each cell In rng
            If Not cell Like "########" Then
                cell.Interior.Color = vbRed
            Else
                cell.Interior.Color = xlNone
            End If
        Next cell
    End If
   
Continue:
    Application.EnableEvents = True
    Exit Sub
Escape:
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Resume Continue
   
End Sub

Thank you, Rick for taking the time edit this. It does not change the cell to highlight red when the cell does not equal 8 digits.

This is what I have so far however, if the value in the cell starts with a zero, the zero disappears. I need to zero to stay as part of the 8 digit value.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet
    Dim cell As Range
    Dim lastRow As Long
    
    Set ws = ThisWorkbook.Worksheets("Items")
    If Not Intersect(Target, ws.Columns("E")) Is Nothing Then
        Application.EnableEvents = False
        For Each cell In Intersect(Target, ws.Columns("E"))
            If Len(cell.Value) <> 8 And cell.Value <> "" Then
                cell.Interior.Color = RGB(255, 0, 0) ' Red
            Else
                cell.Interior.Color = xlNone
            End If
        Next cell
        
        Application.EnableEvents = True
    End If
End Sub

 

[Rick Rothstein]

I just tested my code before I posted it... and I tested it again just now... and it make any entry red unless it is an eight-digit number. I do not know why it is not working the same way for you.

 

[rlv01]

I tested the code @Rick Rothstein posted and it works correctly for me. Be sure that the code is located in a worksheet code module and not a general code module.

 

[justincaza]

Thank you for confirming, Rick and RLV01, much appreciated. The cell does turn red when I enter anything other than 8 digits. However, when the cell is cleared, the red stays. When an associate clears the cell, I need the red clear. I did confirm that when you enter a value that does not equal 8 digits, the cell turns red. Then when you enter 8 digits, the red clears. I also notice that when I enter 01234567, the zero disappears and the cell turns red. I need the zero to stay as part of the 8 digit number.

I also confirmed that I'm using this code in the objects section and not the module section.

Thank you again for taking the time to review posts.

 

[Rick Rothstein]

In my code, change this line of code...

If Not cell Like "########" Then

to this...

If Not cell Like "########" And Len(cell) > 0 Then

As for the problem with leading zeros... change the cell format to Text.

 

[justincaza]

In my code, change this line of code...

If Not cell Like "########" Then

to this...

If Not cell Like "########" And Len(cell) > 0 Then

As for the problem with leading zeros... change the cell format to Text.

Thank you, Rick. This works great. I really appreciate the help with this.