Código:
Function eXl_FechaJuliana(ByVal Fecha As Variant, Optional Ingrese·1·para·Juliana·a·Normal As Boolean = False) As Variant
Dim A As Integer, D As Integer, FN As Date
If Ingrese·1·para·Juliana·a·Normal Then
A = Left(Fecha, 4)
D = Right(Fecha, Len(Fecha) - 4)
On Error Resume Next
FN = DateSerial(A, 1, D)
On Error GoTo 0
If IsDate(FN) Then
eXl_FechaJuliana = FN
Else
eXl_FechaJuliana = CVErr(xlErrValue)
End If
Else
If IsDate(Fecha) Then
A = Year(Fecha)
D = Fecha - DateSerial(A, 1, 0)
eXl_FechaJuliana = A & Format(D, "000")
Else
eXl_FechaJuliana = CVErr(xlErrValue)
End If
End If
End Function
Sub Convertir·eXl_FechaJuliana()
Dim RE As Range, RS As Range, C As Range, F As Variant, M As Variant, A As Integer, D As Integer, FN As Date, R As Variant
On Error Resume Next
Set RE = Application.InputBox("Seleccione el rango que contiene las Fechas Normales o Fechas Julianas:", "Aprendiendo ẽXcel365", Type:=8)
If RE Is Nothing Then Exit Sub
Set RS = Application.InputBox("Seleccione la celda inicial donde desea colocar las fechas convertidas:", "Aprendiendo ẽXcel365", Type:=8)
If RS Is Nothing Then Exit Sub
On Error GoTo 0
M = Application.InputBox("Ingrese 0 para convertir de Normal a Juliana, o 1 para convertir de Juliana a Normal:", "Aprendiendo ẽXcel365", Type:=1)
If M <> 0 And M <> 1 Then
MsgBox "Valor inválido. Solo se acepta 0 o 1.", vbExclamation
Exit Sub
End If
For Each C In RE
F = C.Value
On Error Resume Next
If M = 1 Then
A = Left(F, 4)
D = Right(F, Len(F) - 4)
FN = DateSerial(A, 1, D)
On Error GoTo 0
If IsDate(FN) Then
R = FN
Else
R = CVErr(xlErrValue)
End If
Else
If IsDate(F) Then
A = Year(F)
D = F - DateSerial(A, 1, 0)
R = A & Format(D, "000")
Else
R = CVErr(xlErrValue)
End If
End If
If IsError(R) Then
RS.Offset(C.Row - RE.Row, C.Column - RE.Column).Value = "Error"
Else
RS.Offset(C.Row - RE.Row, C.Column - RE.Column).Value = R
End If
Next C
MsgBox "Conversión completada.", vbInformation, "Aprendiendo ẽXcel365l"
End Sub
👉 Como hacer que la UDF (User Defined Functions) esté disponible como una Función Nativa de Excel
⭐ Si te gustó, por favor regístrate en nuestra Lista de correo y Suscríbete a mi canal de YouTube para que estés siempre enterado de lo nuevo que publicamos.
