Códigos

Los códigos publicados en notas con código, están asimismo en las Notas de google que puedes consultar en mi grupo y proximamente también se podrán consultar en mi web personal

http://juank.mvps.org

Notas con código

Calculo de años, meses y días entre dos fechas

Public Function DamePeriodo(ByVal DesdeFecha As Date, _
ByVal HastaFecha As Date) As String
'---------------------------------------------------------------------------------------
' Procedimiento : DamePeriodo
' Fecha y Hora : 19/09/2007 13:36
' Autor : Ju@nK 2007
' Proposito : Función para sacar los días trabajados entre dos fechas
' cuenta el día de inicio y el de fin
'---------------------------------------------------------------------------------------
' Ju@nK 2007
'
Dim m(2) As Integer, d(2) As Integer, Y(2) As Integer
Dim X As Integer
Dim res(2) As String
On Error GoTo DamePeriodo_Error

X = 0
d(X) = Day(DesdeFecha)
m(X) = Month(DesdeFecha)
Y(X) = Year(DesdeFecha)
X = 1
d(X) = Day(HastaFecha)
m(X) = Month(HastaFecha)
Y(X) = Year(HastaFecha)
If Y(1) + 1 >= Y(0) Then
Y(2) = Y(1) - Y(0)
Else
Y(2) = 0
End If
If m(1) + 1 >= m(0) Then
m(2) = m(1) - m(0)
Else
m(2) = (m(1) + 12) - m(0)
Y(2) = Y(2) - 1
End If
If d(1) + 1 >= d(0) Then
d(2) = (d(1) - d(0)) + 1
Else
m(2) = m(2) - 1
d(2) = (d(1) + Day(DateSerial(Y(1), m(1), 1) - 1)) - d(0) + 1
End If

Select Case Y(2)
Case 0
'nada
res(0) = ""
Case 1
res(0) = Y(2) & " año"
Case Else
res(0) = Y(2) & " años"
End Select

Select Case m(2)
Case 0
'nada
res(1) = ""
Case 1
res(1) = m(2) & " mes"
Case Else
res(1) = m(2) & " meses"
End Select

Select Case d(2)
Case 0
'nada
res(2) = ""
Case 1
res(2) = d(2) & " día"
Case Else
res(2) = d(2) & " días"
End Select

DamePeriodo = res(0)
If DamePeriodo = "" Then
DamePeriodo = res(1)
Else
If res(2) = "" Then
DamePeriodo = DamePeriodo & " y " & res(1)
Else
DamePeriodo = DamePeriodo & ", " & res(1)
End If
End If

If DamePeriodo = "" Then
DamePeriodo = res(2)
Else
If res(2) <> "" Then
DamePeriodo = DamePeriodo & " y " & res(2)
Else
DamePeriodo = DamePeriodo
End If
End If

On Error GoTo 0
Exit Function

DamePeriodo_Error:

MsgBox "Error " & Err.Number & vbCrLf & _
" (" & Err.Description & vbCrLf & _
") en el procedimiento DamePeriodo de Módulo VariosCalculos"
End Function

Public Function FechaLetra(ByVal UnaFecha As Date, _
Optional ByVal Mayusculas As Boolean = True) As String
'---------------------------------------------------------------------------------------
' Procedure : FechaLetra
' DateTime : 20/07/2007 12:44
' Author : © Ju@nK ®
' Purpose : Poner Fechas en letra para fechas hasta el 31/12/2059
'---------------------------------------------------------------------------------------
' © Ju@nK
Dim d As Long
Dim m As Long
Dim y As Long

On Error GoTo FechaLetra_Error

d = Day(UnaFecha)
m = Month(UnaFecha)
y = Year(UnaFecha)

FechaLetra = NumLetra(d) & " de " & Format(UnaFecha, "mmmm") & " de " & NumLetra(y)
'no hay
If Mayusculas Then
FechaLetra = UCase(FechaLetra)
End If

On Error GoTo 0
Exit Function

FechaLetra_Error:

MsgBox "Error " & Err.Number & " (" & Err.Description & ") en procedimiento FechaLetra de Módulo Pasa_Numeros_A_Letras"

End Function

Public Function NumLetra(ByVal UnNumero As Long) As String
'---------------------------------------------------------------------------------------
' Procedure : NumLetra
' DateTime : 20/07/2007 12:43
' Author : © Ju@nK ®
' Purpose : Poner numeros en letra para fechas hasta el 31/12/2059 o números
' con la función de NumDobleLetra, devolviendo moneda en Euros
'---------------------------------------------------------------------------------------
' © Ju@nK
On Error GoTo NumLetra_Error
Dim PartLetra As String

unidades:
Select Case UnNumero
Case 0
If NumLetra = "" Then
NumLetra = "cero"
End If
Case 1
NumLetra = NumLetra & "uno" & PartLetra
Case 2
NumLetra = NumLetra & "dos" & PartLetra
Case 3
NumLetra = NumLetra & "tres" & PartLetra
Case 4
NumLetra = NumLetra & "cuatro" & PartLetra
Case 5
NumLetra = NumLetra & "cinco" & PartLetra
Case 6
NumLetra = NumLetra & "seis" & PartLetra
Case 7
NumLetra = NumLetra & "siete" & PartLetra
Case 8
NumLetra = NumLetra & "ocho" & PartLetra
Case 9
NumLetra = NumLetra & "nueve" & PartLetra
Case 10
NumLetra = NumLetra & "diez" & PartLetra
Case 11
NumLetra = NumLetra & "once" & PartLetra
Case 12
NumLetra = NumLetra & "doce" & PartLetra
Case 13
NumLetra = NumLetra & "trece" & PartLetra
Case 14
NumLetra = NumLetra & "catorce" & PartLetra
Case 15
NumLetra = NumLetra & "quince" & PartLetra
Case 16
NumLetra = NumLetra & "dieciseis" & PartLetra
Case 17
NumLetra = NumLetra & "diecisiete" & PartLetra
Case 18
NumLetra = NumLetra & "dieciocho" & PartLetra
Case 19
NumLetra = NumLetra & "diecinueve" & PartLetra
Case 20
NumLetra = NumLetra & "veinte" & PartLetra
Case 21 To 29
NumLetra = NumLetra & "venti"
UnNumero = UnNumero - 20
GoTo unidades
Case 30 To 39
NumLetra = NumLetra & "treinta"
UnNumero = UnNumero - 30
If UnNumero <> 0 Then
NumLetra = NumLetra & " y "
GoTo unidades
End If
Case 40 To 49
NumLetra = NumLetra & "cuarenta"
UnNumero = UnNumero - 40
If UnNumero <> 0 Then
NumLetra = NumLetra & " y "
GoTo unidades
End If
Case 50 To 59
NumLetra = NumLetra & "cincuenta"
UnNumero = UnNumero - 50
If UnNumero <> 0 Then
NumLetra = NumLetra & " y "
GoTo unidades
End If
Case 60 To 69
NumLetra = NumLetra & "sesenta"
UnNumero = UnNumero - 60
If UnNumero <> 0 Then
NumLetra = NumLetra & " y "
GoTo unidades
End If
Case 70 To 79
NumLetra = NumLetra & "setenta"
UnNumero = UnNumero - 70
If UnNumero <> 0 Then
NumLetra = NumLetra & " y "
GoTo unidades
End If
Case 80 To 89
NumLetra = NumLetra & "ochenta"
UnNumero = UnNumero - 80
If UnNumero <> 0 Then
NumLetra = NumLetra & " y "
GoTo unidades
End If
Case 90 To 99
NumLetra = NumLetra & "noventa"
UnNumero = UnNumero - 90
If UnNumero <> 0 Then
NumLetra = NumLetra & " y "
GoTo unidades
End If
Case 100 To 199
UnNumero = UnNumero - 100
If UnNumero <> 0 Then
NumLetra = NumLetra & "ciento "
Else
NumLetra = NumLetra & "cien "
End If
GoTo unidades
Case 200 To 299
UnNumero = UnNumero - 200
NumLetra = NumLetra & "doscientos "
GoTo unidades
Case 300 To 399
UnNumero = UnNumero - 300
NumLetra = NumLetra & "trescientos "
GoTo unidades
Case 400 To 499
UnNumero = UnNumero - 400
NumLetra = NumLetra & "cuatrocientos "
GoTo unidades
Case 500 To 599
UnNumero = UnNumero - 500
NumLetra = NumLetra & "quinientos "
GoTo unidades
Case 600 To 699
UnNumero = UnNumero - 600
NumLetra = NumLetra & "seiscientos "
GoTo unidades
Case 700 To 799
UnNumero = UnNumero - 700
NumLetra = NumLetra & "setecientos "
GoTo unidades
Case 800 To 899
UnNumero = UnNumero - 800
NumLetra = NumLetra & "ochocientos "
GoTo unidades
Case 900 To 999
UnNumero = UnNumero - 900
NumLetra = NumLetra & "novecientos "
GoTo unidades
'Parte dejada para compatibilidad en fechas, hasta el año 2999 _
**************************************************************
Case 1000 To 1999 'no definido mas, no hace falta
NumLetra = NumLetra & "mil"
UnNumero = UnNumero - 1000
If UnNumero <> 0 Then
NumLetra = NumLetra & " "
GoTo unidades
End If
Case 2000 To 2999 'no definido mas, no hace falta
NumLetra = NumLetra & "dos mil"
UnNumero = UnNumero - 2000
If UnNumero <> 0 Then
NumLetra = NumLetra & " "
GoTo unidades
End If
'**************************************************************
Case Else
NumLetra = "No definido para este número, llamar al programador :-) Ju@nK"
Stop
End Select

On Error GoTo 0
Exit Function

NumLetra_Error:

MsgBox "Error " & Err.Number & " (" & Err.Description & ") en procedimiento NumLetra de Módulo Pasa_Numeros_A_Letras"
End Function

Public Function NumDobleLetra(ByVal elNum As Double, _
Optional ByVal numDec As Long = 2) As String
'---------------------------------------------------------------------------------------
' Procedure : NumDobleLetra
' DateTime : 06/08/2007 13:09
' Author : © Ju@nK ®
' Purpose : Pasar numeros a letra hasta 1 billón menos un céntimo
' Utiliza también la función Numletra para sus cálculos.
'---------------------------------------------------------------------------------------
' © Ju@nK 2007
Dim EntNum As Double
Dim DecNum As Double
Dim entLet As String
Dim decLet As String
Dim numCal As Double
Dim x As Long

On Error GoTo NumDobleLetra_Error

x = InStr(1, CStr(elNum), ",", vbTextCompare) + 1

If x > 1 Then
DecNum = CLng(Mid(CStr(elNum), x, numDec))
Else
DecNum = 0
End If
EntNum = Int(elNum)
calculos:
'Parte entera
enteros:
x = Len(CStr(EntNum))
Select Case x
Case 1 To 3
'1 a 999
entLet = NumLetra(EntNum)
Case 4 To 6
'1000 a 999999
'parte centenas
entLet = NumLetra(Right(EntNum, 3))
'miles
If Left(EntNum, x - 3) <> 1 Then
entLet = NumLetra(Left(EntNum, x - 3)) & " mil " & entLet
Else
entLet = "mil " & entLet
End If
Case 7 To 9
'millones 1 a 999
numCal = Mid(EntNum, 1, x - 6)
entLet = IIf(numCal = 1, "un", NumLetra(numCal)) & " millon" & _
IIf(numCal <> 1, "es ", " ")
EntNum = EntNum - (numCal * 10 ^ 6)
NumDobleLetra = NumDobleLetra & entLet
GoTo enteros
Case 10 To 12
'miles de millones 1 a 999
numCal = Mid(EntNum, 1, x - 9)
entLet = LTrim(IIf(numCal = 1, "", NumLetra(numCal)) & " mil") & _
IIf(numCal <> 1, " ", " ")
EntNum = EntNum - (numCal * 10 ^ 9)
NumDobleLetra = NumDobleLetra & entLet
GoTo enteros
Case Else
'no previsto
End Select
NumDobleLetra = NumDobleLetra & entLet & " euro" & _
IIf(EntNum <> 1, "s", "")
'Parte decimal
decimales:
If DecNum = 1 Then
decLet = "un céntimo"
Else
decLet = NumLetra(DecNum) & IIf(DecNum > 0, " con " & decLet & " céntimos", "")
End If
'numero completo

NumDobleLetra = NumDobleLetra & decLet

On Error GoTo 0
Exit Function

NumDobleLetra_Error:

MsgBox "Error " & Err.Number & " (" & Err.Description & ") en procedimiento NumDobleLetra de Módulo Pasa_Numeros_A_Letras"
End Function

Funciones para convertir numeros a moneda en euros Ju@nK 2007

Fotos en Piñeres

En la casa de Piñeres