** NORMAS DEL FORO **
Inicio del foro Inicio del foro > Access y VBA > Access y VBA
  Mensajes nuevos Mensajes nuevos RSS - MIGRAR CODIGO DE EXCEL A ACCESS
  Preguntas frecuentes Preguntas frecuentes  Buscar en el foro   Eventos   Registro Registro  Iniciar sesion Iniciar sesion

Tema cerradoMIGRAR CODIGO DE EXCEL A ACCESS

 Responder Responder
Autor
Mensaje
JJESTRADAMO Ver desplegable
Nuevo
Nuevo


Unido: 13/Enero/2016
Localización: MEXICO
Estado: Sin conexión
Puntos: 13
Enlace directo a este mensaje Tema: MIGRAR CODIGO DE EXCEL A ACCESS
    Enviado: 22/Enero/2016 a las 20:29
Me gustaría saber si hay forma de migrar este código que funciona correctamente en Excel a Access.

La idea es crear una tabla con los campos como si fueran de excel y crear una consulta de selección, donde el código me muestre el calculo que realizo, como campo calculado.

O bien si alguno me puede dar otra sugerencia.

Muchas gracias de antemano.

Este es el código:

Public Function RFC(nombre As String, _
paterno As String, _
materno As String, _
nacimiento As Date) As String

Dim nombreRFC, paternoRFC, maternoRFC, claveRFC As String

'Aplicar formato y remover palabras y nombres de textos
nombreRFC = RemoverNombres(RemoverPalabras(FormatoTextoRFC(nombre)))
paternoRFC = RemoverPalabras(FormatoTextoRFC(paterno))
maternoRFC = RemoverPalabras(FormatoTextoRFC(materno))

'Generar las 4 primeras letras y sustituir palabras prohibidas
claveRFC = SustituirProhibidas(LetrasRFC(nombreRFC, paternoRFC, maternoRFC))

'Concatenar dígitos de fecha de nacimiento
claveRFC = claveRFC & Format(nacimiento, "yymmdd")

'Generar homonimia y concatenar al RFC
claveRFC = claveRFC & Homoclave(FormatoTextoRFC(nombre), _
FormatoTextoRFC(paterno), FormatoTextoRFC(materno))

'Generar dígito verificador y concatenar al RFC
claveRFC = claveRFC & DigitoVerificador(claveRFC)

'Devolver RFC final
RFC = claveRFC
End Function

Private Function FormatoTextoRFC(ByVal texto As String) As String

texto = UCase(texto)
texto = Replace(texto, "Á", "A")
texto = Replace(texto, "É", "E")
texto = Replace(texto, "Í", "I")
texto = Replace(texto, "Ó", "O")
texto = Replace(texto, "Ú", "U")

FormatoTextoRFC = texto
End Function

Private Function RemoverPalabras(ByVal texto As String) As String

Dim palabras As Variant
Dim i As Integer

palabras = Array(" PARA ", " AND ", " CON ", " DEL ", " LAS ", " LOS ", _
" MAC ", " POR ", " SUS ", " THE ", " VAN ", " VON ", " AL ", " DE ", _
" EL ", " EN ", " LA ", " MC ", " MI ", " OF ", " A ", " E ", " Y ")

texto = " " & texto
For i = LBound(palabras) To UBound(palabras)
    texto = Replace(texto, palabras(i), " ")
Next i

RemoverPalabras = Trim(texto)
End Function

Private Function RemoverNombres(ByVal texto As String) As String

Dim nombres As Variant
Dim i As Integer

nombres = Array(" MARIA ", " JOSE ", " MA. ", " MA ", " J. ", " J ")

If InStr(texto, " ") > 0 Then
    texto = " " & texto
    For i = LBound(nombres) To UBound(nombres)
        texto = Replace(texto, nombres(i), " ")
    Next i
End If

RemoverNombres = Trim(texto)
End Function

Private Function LetrasRFC(ByVal nombre As String, _
ByVal paterno As String, _
ByVal materno As String) As String

Dim vocales, vocal, letras As String
Dim i As Integer

vocales = "AEIOU"

If Len(materno) = 0 Then
    letras = Left(paterno, 2) & Left(nombre, 2)
ElseIf Len(paterno) < 3 Then
    letras = Left(paterno, 1) & Left(materno, 1) & Left(nombre, 2)
Else
    For i = 2 To Len(paterno)
        If InStr(vocales, Mid(paterno, i, 1)) > 0 Then
            vocal = Mid(paterno, i, 1)
            Exit For
        End If
    Next i
    letras = Left(paterno, 1) & vocal & Left(materno, 1) & Left(nombre, 1)
End If

LetrasRFC = letras
End Function

Private Function SustituirProhibidas(ByVal texto As String) As String

Dim prohibidas As Variant
Dim i As Integer

prohibidas = Array("BUEI", "BUEY", "CACA", "CACO", "CAGA", "CAGO", _
"CAKA", "CAKO", "COGE", "COJA", "COJE", "COJI", "COJO", "CULO", _
"FETO", "GUEY", "JOTO", "KACA", "KACO", "KAGA", "KAGO", "KAKA", _
"KOGE", "KOJO", "KULO", "MAME", "MAMO", "MEAR", "MEAS", "MEON", _
"MION", "MOCO", "MULA", "PEDA", "PEDO", "PENE", "PUTA", "PUTO", _
"QULO", "RATA", "RUIN")

For i = LBound(prohibidas) To UBound(prohibidas)
    texto = Replace(texto, prohibidas(i), Left(texto, 3) & "X")
Next i

SustituirProhibidas = texto
End Function

Private Function Homoclave(ByVal nombre As String, _
ByVal paterno As String, _
ByVal materno As String) As String

Dim nombreCompleto, cadenaNums, equivalencia, caracter As String
Dim i, numero1, numero2, suma, cociente, residuo As Integer

equivalencia = "123456789ABCDEFGHIJKLMNPQRSTUVWXYZ"
nombreCompleto = nombre & " " & paterno & " " & materno

For i = 1 To Len(nombreCompleto)
    caracter = Mid(nombreCompleto, i, 1)
    Select Case caracter
        Case " "
            cadenaNums = cadenaNums & "00"
        Case "&"
            cadenaNums = cadenaNums & "10"
        Case "Ñ"
            cadenaNums = cadenaNums & "40"
        Case "A" To "I"
            cadenaNums = cadenaNums & CStr(Asc(caracter) - 54)
        Case "J" To "R"
            cadenaNums = cadenaNums & CStr(Asc(caracter) - 53)
        Case "S" To "Z"
            cadenaNums = cadenaNums & CStr(Asc(caracter) - 51)
    End Select
Next i

cadenaNums = "0" & cadenaNums

For i = 1 To Len(cadenaNums) - 1
    numero1 = Val(Mid(cadenaNums, i, 2))
    numero2 = Val(Mid(cadenaNums, i + 1, 1))
    suma = suma + numero1 * numero2
Next i

cociente = Int(Val(Right(CStr(suma), 3)) / 34)
residuo = Val(Right(CStr(suma), 3)) Mod 34

Homoclave = Mid(equivalencia, cociente + 1, 1) & _
Mid(equivalencia, residuo + 1, 1)
End Function

Private Function DigitoVerificador(ByVal texto As String) As String

Dim cadenaNums, caracter, digito As String
Dim i, j, cont, numero, suma, residuo As Integer

For i = 1 To Len(texto)
    caracter = Mid(texto, i, 1)
    Select Case caracter
        Case " "
            cadenaNums = cadenaNums & "37"
        Case "&"
            cadenaNums = cadenaNums & "24"
        Case "Ñ"
            cadenaNums = cadenaNums & "38"
        Case "A" To "N"
            cadenaNums = cadenaNums & CStr(Asc(caracter) - 55)
        Case "O" To "Z"
            cadenaNums = cadenaNums & CStr(Asc(caracter) - 54)
        Case "0" To "9"
            cadenaNums = cadenaNums & Format(caracter, "00")
    End Select
Next i

cont = 0
For j = 1 To 23 Step 2
    numero = Val(Mid(cadenaNums, j, 2))
    suma = suma + (numero * (13 - cont))
    cont = cont + 1
Next j

residuo = suma Mod 11

Select Case residuo
    Case 0:
        digito = "0"
    Case 10:
        digito = "A"
    Case Else
        digito = 11 - residuo
End Select

DigitoVerificador = digito
End Function


Arriba
xavi Ver desplegable
Administrador
Administrador
Avatar
Terrassa-BCN

Unido: 10/Mayo/2005
Localización: Catalunya ||||
Estado: Sin conexión
Puntos: 11918
Enlace directo a este mensaje Enviado: 23/Enero/2016 a las 10:04
Hola,

He leído el código por encima y no se ver nada que impida que ese código funcione en Access. En ningún momento parece que se utilicen palabras claves específicas de Excel por lo que no veo el problema.

Un saludo
Xavi, un minyó de Terrassa

Mi web
Arriba
 Responder Responder
  Compartir tema   

Ir al foro Permisos de foro Ver desplegable