Option Explicit Public Function LETRA_CIF(stCIF As String) As String '************************************************************* 'Función usada para calcular la letra del NIF correspondiente 'Creado por José Mª Fueyo. '************************************************************* On Error GoTo Letra_CifERROR Dim lngVALOR As Long, intENTERO As Long lngVALOR = CLng(stCIF) intENTERO = lngVALOR - ((Fix(lngVALOR / 23)) * 23) + 1 Select Case intENTERO Case 1, 24 LETRA_CIF = "T" Case 2 LETRA_CIF = "R" Case 3 LETRA_CIF = "W" Case 4 LETRA_CIF = "A" Case 5 LETRA_CIF = "G" Case 6 LETRA_CIF = "M" Case 7 LETRA_CIF = "Y" Case 8 LETRA_CIF = "F" Case 9 LETRA_CIF = "P" Case 10 LETRA_CIF = "D" Case 11 LETRA_CIF = "X" Case 12 LETRA_CIF = "B" Case 13 LETRA_CIF = "N" Case 14 LETRA_CIF = "J" Case 15 LETRA_CIF = "Z" Case 16 LETRA_CIF = "S" Case 17 LETRA_CIF = "Q" Case 18 LETRA_CIF = "V" Case 19 LETRA_CIF = "H" Case 20 LETRA_CIF = "L" Case 21 LETRA_CIF = "C" Case 22 LETRA_CIF = "K" Case 23 LETRA_CIF = "E" End Select Exit Function 'Control de errores Letra_CifERROR: If Err.Number = 13 Then MsgBox "INTRODUCE UN NÚMERO, SIN LETRAS", vbOKOnly + vbExclamation, "¡BURRO!" Else MsgBox Err.Number & vbCrLf & Err.Description End If End Function Public Function VALIDAR_NIF(sNIF As String) As Boolean 'FUNCION QUE VALIDA UN VALOR DE NIF '9 ALFANUMÉRICOS, EL ULTIMO LETRA. Dim lngVALOR As Long, intENTERO As Long, sLetra As String If Len(Trim(sNIF)) <> 9 Then 'Compruebo longitud=9 VALIDAR_NIF = False Else 'Compruebo si letra sLetra = UCase(Right(sNIF, 1)) If sLetra >= "A" And sLetra <= "Z" Then lngVALOR = Val(sNIF) intENTERO = lngVALOR - ((Fix(lngVALOR / 23)) * 23) + 1 Select Case intENTERO Case 1, 24 If sLetra = "T" Then VALIDAR_NIF = True Else VALIDAR_NIF = False End If Case 2 If sLetra = "R" Then VALIDAR_NIF = True Else VALIDAR_NIF = False End If Case 3 If sLetra = "W" Then VALIDAR_NIF = True Else VALIDAR_NIF = False End If Case 4 If sLetra = "A" Then VALIDAR_NIF = True Else VALIDAR_NIF = False End If Case 5 If sLetra = "G" Then VALIDAR_NIF = True Else VALIDAR_NIF = False End If Case 6 If sLetra = "M" Then VALIDAR_NIF = True Else VALIDAR_NIF = False End If Case 7 If sLetra = "Y" Then VALIDAR_NIF = True Else VALIDAR_NIF = False End If Case 8 If sLetra = "F" Then VALIDAR_NIF = True Else VALIDAR_NIF = False End If Case 9 If sLetra = "P" Then VALIDAR_NIF = True Else VALIDAR_NIF = False End If Case 10 If sLetra = "D" Then VALIDAR_NIF = True Else VALIDAR_NIF = False End If Case 11 If sLetra = "X" Then VALIDAR_NIF = True Else VALIDAR_NIF = False End If Case 12 If sLetra = "B" Then VALIDAR_NIF = True Else VALIDAR_NIF = False End If Case 13 If sLetra = "N" Then VALIDAR_NIF = True Else VALIDAR_NIF = False End If Case 14 If sLetra = "J" Then VALIDAR_NIF = True Else VALIDAR_NIF = False End If Case 15 If sLetra = "Z" Then VALIDAR_NIF = True Else VALIDAR_NIF = False End If Case 16 If sLetra = "S" Then VALIDAR_NIF = True Else VALIDAR_NIF = False End If Case 17 If sLetra = "Q" Then VALIDAR_NIF = True Else VALIDAR_NIF = False End If Case 18 If sLetra = "V" Then VALIDAR_NIF = True Else VALIDAR_NIF = False End If Case 19 If sLetra = "H" Then VALIDAR_NIF = True Else VALIDAR_NIF = False End If Case 20 If sLetra = "L" Then VALIDAR_NIF = True Else VALIDAR_NIF = False End If Case 21 If sLetra = "C" Then VALIDAR_NIF = True Else VALIDAR_NIF = False End If Case 22 If sLetra = "K" Then VALIDAR_NIF = True Else VALIDAR_NIF = False End If Case 23 If sLetra = "E" Then VALIDAR_NIF = True Else VALIDAR_NIF = False End If End Select Else VALIDAR_NIF = False End If End If End Function Public Function VALIDAR_CIF(sCIF As String) As Boolean 'Compruebo si un CIF pasado es válido o no 'Tiene que tener 9 caracteres. 'Para guardar el primer y último caracter Dim sPRI As String, sULT As String, sRESTO As String, i As Integer 'Para la suma de posiciones Dim iSUMA As Integer, sIMPARES(1 To 4) As String If Len(Trim(sCIF)) <> 9 Then 'Compruebo que sea de 9 caracteres VALIDAR_CIF = False Else sPRI = UCase(Left(sCIF, 1)) 'Guarda letra sULT = Right(sCIF, 1) 'Guarda dígito de control sRESTO = Mid(sCIF, 2, 7) 'Guarda cuerpo CIF, usado para cálculo 'Suma de posiciones pares iSUMA = CInt(Mid(sRESTO, 2, 1)) + CInt(Mid(sRESTO, 4, 1)) + CInt(Mid(sRESTO, 6, 1)) 'Multiplico posiciones impares por dos, 'y sumo cifras resultantes sIMPARES(1) = Format(2 * CInt(Mid(sRESTO, 1, 1)), "00") sIMPARES(2) = Format(2 * CInt(Mid(sRESTO, 3, 1)), "00") sIMPARES(3) = Format(2 * CInt(Mid(sRESTO, 5, 1)), "00") sIMPARES(4) = Format(2 * CInt(Mid(sRESTO, 7, 1)), "00") For i = 1 To 4 iSUMA = iSUMA + (CInt(Left(sIMPARES(i), 1)) + CInt(Right(sIMPARES(i), 1))) Next i 'Obtengo la posición de unidades If Not sPRI = "X" And Not sPRI = "P" And Not sPRI = "S" And Not sPRI = "Q" Then 'No es ayuntamiento/extranjero If sULT = Right(CStr(10 - CInt(Right(CStr(iSUMA), 1))), 1) Then VALIDAR_CIF = True Else VALIDAR_CIF = False End If Else 'Ayuntamiento/Extranjero. Busco letra control If sULT = Chr(64 + (10 - CInt(Right(CStr(iSUMA), 1)))) Then VALIDAR_CIF = True Else VALIDAR_CIF = False End If End If End If End Function Function iCalculaCif(sCIF As String) As Integer ' Objetivo: ' Procedimiento que chequea la validez del CIF. ' Parámetros: ' Nif. String. Contiene el NIF introducido. ' iVuelta. String. Devuelve el resultado del chequeo. ' Resultado: ' True/False si el chequeo es correcto o incorrecto. Dim i As Integer, Tr As Integer, Tr1 As Integer, Decena As Integer Dim sLetra As String, sAux As String, sAux2 As String, sMultip As String If Len(sCIF) < 9 Then Exit Function Else sLetra = UCase$(Left$(sCIF, 1)) 'Guarda la primera letra. 'If InStr("QPS", sLetra) And Not IsNumeric(Right$(sCif, 1)) Then ' sCif = Left$(sCif, Len(sCif) - 1) & Asc(Right(sCif, 1)) - 64 'End If 'Coge solamente los números. sAux = Right$(sCIF, Len(sCIF) - 1) 'Quita la letra del CIF. sAux2 = "" For i = 1 To Len(sAux) If IsNumeric(Mid$(sAux, i, 1)) Then sAux2 = sAux2 & Mid$(sAux, i, 1) End If Next i If Len(sAux2) <> 8 Then Exit Function Else sAux = sAux2 sMultip = "2121212" 'Multiplicar por los 7 primeros dígitos. Tr1 = 0 For i = 1 To 7 Tr = Val(Mid$(sAux, i, 1)) * Val(Mid$(sMultip, i, 1)) If Tr > 9 Then Tr = Tr - 9 End If Tr1 = Tr1 + Tr Next i If Right$(Str$(Tr1), 1) = "0" Then Decena = Tr1 Else Decena = (Int(Tr1 / 10) + 1) * 10 End If If Val(Right$(sAux, 1)) = Decena - Tr1 Then ' C.I.F. Correcto iCalculaCif = True ' Los CIF que empiezan por P,Q o S sustituyen su último dígito por la letra correspondiente (A-1,B-2 etc) 'If InStr("QPS", sLetra) Then ' sCif = Left$(sCif, Len(sCif) - 1) & Chr$(Right(sCif, 1) + 64) 'End If Else Exit Function End If End If End If End Function