Te voy a mandar un fichero para que lo pruebes y me dices si hay que cambiar algo. No está a lo mejor bien del todo no terminado, pero es que tengo que dejar ahora el ordenador unas horas y quiero que lo vayas probando y me dices lo que no esté bien.
El programa se basa en unas variables globales y una macro que esta en la misma hoja donde los datos y unas funciones. Pero ahora no tengo tiempo par explicar, luego si acaso.
Estas son las variables que hay que declarar en un modulo Visual basic
Public Const AlfaMay = "ABCDEFGHIJKLMNÑOPQRSTUVWXYZ"
Public Const AlfaMin = "abcdefghijklmnñopqrstuvwxyz"
Public Const Alfa = AlfaMay & AlfaMin
Public Const Numérico = "0123456789"
Public Const AlfaNum = Alfa & Numérico
Public Const AlfaMayNum = AlfaMay & Numérico
Public Const AlfaMinNum = AlfaMin & Numérico
Y esta es la macro y funciones de la hoja sin indentar porque la página las quita, es inútil indentar las instrucciones.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Celda As Range
Dim Respuesta As Integer
Dim FechaBuena As Boolean
For Each Celda In Target
If Not Intersect(Celda, Range("A5:A100")) Is Nothing Then
If Len(Celda) <> 11 And Len(Celda) <> 0 Or Not CadenaValida(Celda, AlfaMayNum) Then
Celda.Select
Respuesta = MsgBox("La celda " & Replace(Celda.Address, "$", "") & " debe tener 11 caracteres alfanúméricos (o ninguno)", _
vbInformation + vbOKOnly, "ERROR EN EL DATO")
SendKeys "{F2}"
End If
ElseIf Not Intersect(Celda, Range("E5:E100")) Is Nothing Then
If Len(Celda) > 30 Or Not CadenaValida(Celda, AlfaMayNum) Then
Celda.Select
Respuesta = MsgBox("La celda " & Replace(Celda.Address, "$", "") & " debe tener de 1 a 31 caracteres alfanúméricos (o ninguno)", _
vbInformation + vbOKOnly, "ERROR EN EL DATO")
SendKeys "{F2}"
End If
ElseIf Not Intersect(Celda, Range("G5:G100")) Is Nothing Then
FechaBuena = False
If Len(Celda) <> 8 Then
If CadenaValida(Celda, Numerico) Then
If FechaCorrecta(Celda.Text) Then FechaBuena = True
End If
End If
If Celda = "" Then FechaBuena = True
If Not FechaBuena Then
Celda.Select
Respuesta = MsgBox("La celda " & Replace(Celda.Address, "$", "") & " debe tener una fecha válida de 8 numeros (o ninguno)", _
vbInformation + vbOKOnly, "ERROR EN EL DATO")
SendKeys "{F2}"
End If
ElseIf Not Intersect(Celda, Range("H5,H100")) Is Nothing Then
If Len(Celda) <> 8 Or Not CadenaValida(Celda, Numerico) Then
Celda.Select
Respuesta = MsgBox("La celda " & Replace(Celda.Address, "$", "") & " debe tener 8 caracteres numéricos (o ninguno)", _
vbInformation + vbOKOnly, "ERROR EN EL DATO")
SendKeys "{F2}"
End If
End If
Next
End Sub
Private Function CadenaValida(Cadena, CarValidos As String) As Boolean
Dim i As Integer
CadenaValida = True
If Cadena = "" Then Exit Function
For i = 1 To Len(Cadena)
If InStr(CarValidos, Mid(Cadena, i, 1)) = 0 Then
CadenaValida = False
Exit For
End If
Next
End Function
Private Function FechaCorrecta(Cadena As String) As Boolean
Dim dia, Mes, Año As Integer
dia = Val(Left(Cadena, 2))
Mes = Val(Mid(Cadena, 3, 2))
Año = Val(Mid(Cadena, 5, 4))
FechaCorrecta = False
If Mes = 0 Or Mes > 12 Then Exit Function
If dia = 0 Or dia > 31 Then Exit Function
If dia = 31 And (Mes = 2 Or Mes = 4 Or Mes = 6 Or Mes = 9 Or Mes = 11) Then Exit Function
If dia = 30 And Mes = 2 Then Exit Function
If dia = 29 And Año Mod 4 <> 0 Then Exit Function
If dia = 29 And Año Mod 100 = 0 And Año Mod 400 <> 0 Then Exit Function
FechaCorrecta = True
End Function
Y aquí tienes el libro para descargar, pruébalo pero no es definitivo si hay algún error o quieres alguna modificación.
ValidacionRangosColumnas.xlsm