Convertir Fecha Normal a Juliana y Viceversa en VBA Excel

Código UDF

Function Fecha·Normal·a·Juliana·Viceversa(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

Fecha·Normal·a·Juliana·Viceversa = FN

Else

Fecha·Normal·a·Juliana·Viceversa = CVErr(xlErrValue)

End If

Else

If IsDate(Fecha) Then

A = Year(Fecha)

D = Fecha - DateSerial(A, 1, 0)

Fecha·Normal·a·Juliana·Viceversa = A & Format(D, "000")

Else

Fecha·Normal·a·Juliana·Viceversa = CVErr(xlErrValue)

End If

End If

End Function

Código Procedimiento

Sub Convertir·Fecha·Normal·a·Juliana·Viceversa()

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:", "INGENIERÍA & BURÓTICA", Type:=8)

If RE Is Nothing Then Exit Sub

Set RS = Application.InputBox("Seleccione la celda inicial donde desea colocar las fechas convertidas:", "INGENIERÍA & BURÓTICA", 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:", "INGENIERÍA & BURÓTICA", Type:=1)

If M <> 0 And M <> 1 Then

MsgBox "M 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, "INGENIERÍA & BURÓTICA"

End Sub