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

 

[kevin9999]

See if the following gives you what you want:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Range("A:A"), Target) Is Nothing Then
        On Error GoTo Escape
        Application.EnableEvents = False
        If Not IsNumeric(Target) Or Len(Target) <> 8 Then
            MsgBox "Entry Must Equal 8 Digits"
            Target.ClearContents: Target.Select
        End If
    End If
Continue:
    Application.EnableEvents = True
    Exit Sub
Escape:
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Resume Continue
End Sub

 

[Rick Rothstein]

See if the following gives you what you want:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Range("A:A"), Target) Is Nothing Then
        On Error GoTo Escape
        Application.EnableEvents = False
        If Not IsNumeric(Target) Or Len(Target) <> 8 Then
            MsgBox "Entry Must Equal 8 Digits"
            Target.ClearContents: Target.Select
        End If
    End If
Continue:
    Application.EnableEvents = True
    Exit Sub
Escape:
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Resume Continue
End Sub

IsNumeric is not a good function to use to test if a text string is a number or not. For example, if Target is assigned "&HEAD123" then it will not be caught by your test line. Try changing your test to this and it should always work...

If Not Target Like "########" Then

 

[kevin9999]

Good advice @Rick Rothstein , amended code below:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Range("A:A"), Target) Is Nothing Then
        On Error GoTo Escape
        Application.EnableEvents = False
        If Not Target Like "########" Then
            MsgBox "Entry Must Equal 8 Digits"
            Target.ClearContents: Target.Select
        End If
    End If
Continue:
    Application.EnableEvents = True
    Exit Sub
Escape:
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Resume Continue
End Sub

 

[justincaza]

Thank you for helping with this, much appreciated.

After testing, I ran into an issue where when multiple cells were pasted I got a "error 13: type mismatch" and the pasted cells were not cleared.

 

[Joe4]

I just amended Kevin's code to handle multi-cell copy/pastes:

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
                MsgBox "Entry Must Equal 8 Digits"
                cell.ClearContents: cell.Select
            End If
        Next cell
    End If
    
Continue:
    Application.EnableEvents = True
    Exit Sub
Escape:
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Resume Continue
    
End Sub

 

[justincaza]

Works great, thank you for everyone's support, much appreciated.

 

[justincaza]

Okay, looking for additional help if possible to modify the code....

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
                MsgBox "Entry Must Equal 8 Digits"
                cell.ClearContents: cell.Select
            End If
        Next cell
    End If
   
Continue:
    Application.EnableEvents = True
    Exit Sub
Escape:
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Resume Continue
   
End Sub

- I need to take out the message box and instead highlight the cell red until the cell has an 8 digit value, then clear the red. This should also include any pasted values and any spaces or special characters
- I also need to make sure this code includes the option for leading zeros. Example, we could have a number 12345678 or 01234567

Thank you in advance for the support

 

[rlv01]

FYI, when posting your code, you should really try to use code tags, same as everyone who previously helped you has done. It makes your code easier for others to read and copy.

How to:

How to Post Your VBA Code

Post your VBA code.

www.mrexcel.com

 

[justincaza]

My apologies...Hope this helps.

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
                MsgBox "Entry Must Equal 8 Digits"
                cell.ClearContents: cell.Select
            End If
        Next cell
    End If
    
Continue:
    Application.EnableEvents = True
    Exit Sub
Escape:
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Resume Continue
    
End Sub