ich habe das Problem, dass ich Datum(s)? ;-) gregorianisch in persisch wandeln muss.
Kennt jemand von euch vllt. eine Formel?
Oder lässt sich das in vba lösen?
Ich habe schon viel gesucht (google), das meiste war in Englisch und nur schwer nachzuvollziehen. Bin auch nicht so der VBA Crack. Ich habe einen Code gefunden, weiß aber nicht wie ich die Funktionen aufrufen soll.
Kann mir jemand helfen:
- mit einer Formellösung
- einem eigenen VBA Code
oder den von mir gefundenen zu verstehen und einzusetzen?
Option Explicit
Const Jofst As Double = 2415018.5
Function Civil2Persian(dat As Date) As Variant
' Converts a Civil (Gregorian) date
' to a Variant containing Persian year, month, and day
' E.g., Civil2Persian(DATE(2007, 12, 1)) = {1386, 9, 10}
' N.B.: Must be entered as an array formula
Civil2Persian = Julian2Persian(Civil2Julian(dat))
End Function
Function Persian2Civil(iYear As Integer, iMonth As Integer, iDay As Integer) As Date
' Converts a Persian year, month, and day to a Civil (Gregorian) date
' E.g., Persian2Civil(1386, 9, 10) = 39417 = 2007 Dec 01
Persian2Civil = Int(Julian2Civil(Persian2Julian(iYear, iMonth, iDay)))
End Function
Function PersianString2Civil(s As String) As Date
' Converts a string containing Persian year, month, and day
' to a Civil (Gregorian) date
' E.g., Persian2Civil("1386, 9, 10") = 39417 = 2007 Dec 01
Dim astr() As String
astr = Split(s, ",")
PersianString2Civil = Persian2Civil(CInt(astr(0)), CInt(astr(1)), CInt(astr(2)))
End Function
Function Civil2Julian(dat As Date) As Double
Civil2Julian = dat + Jofst
End Function
Function Julian2Civil(jdn As Long) As Date
Julian2Civil = jdn - Jofst
End Function
Function Persian2Julian(iYear As Integer, _
iMonth As Integer, _
iDay As Integer) As Long
Const PERSIAN_EPOCH = 1948321 ' The Julian of 1 Farvardin 1
Dim epbase As Long
Dim epyear As Long
Dim mdays As Long
If iYear >= 0 Then
epbase = iYear - 474
Else
epbase = iYear - 473
End If
epyear = 474 + (epbase Mod 2820)
If iMonth mdays = (CLng(iMonth) - 1) * 31
Else
mdays = (CLng(iMonth) - 1) * 30 + 6
End If
Persian2Julian = CLng(iDay) _
+ mdays _
+ Fix(((epyear * 682) - 110) / 2816) _
+ (epyear - 1) * 365 _
+ Fix(epbase / 2820) * 1029983 _
+ (PERSIAN_EPOCH - 1)
End Function
Function Julian2Persian(jdn As Long) As Variant
Dim depoch
Dim cycle
Dim cyear
Dim ycycle
Dim aux1, aux2
Dim yday
Dim iYear As Integer
Dim iMonth As Integer
Dim iDay As Integer
depoch = jdn - Persian2Julian(475, 1, 1)
cycle = Fix(depoch / 1029983)
cyear = depoch Mod 1029983
If cyear = 1029982 Then
ycycle = 2820
Else
aux1 = Fix(cyear / 366)
aux2 = cyear Mod 366
ycycle = Int(((2134 * aux1) + (2816 * aux2) + 2815) / 1028522) + aux1 + 1
End If
iYear = ycycle + (2820 * cycle) + 474
If iYear iYear = iYear - 1
End If
yday = (jdn - Persian2Julian(iYear, 1, 1)) + 1
If yday iMonth = Ceil(yday / 31)
Else
iMonth = Ceil((yday - 6) / 30)
End If
iDay = (jdn - Persian2Julian(iYear, iMonth, 1)) + 1
Julian2Persian = Array(iYear, iMonth, iDay)
End Function
' We needed an alternative to Int and Fix
' Int(8.4) = 8, Int(-8.4) = -9
' Fix(8.4) = 8, Fix(-8.4) = -8
' Ceil(8.4) = 9, Ceil(-8.4) = -9 Private Function Ceil(number As Single) As Long Ceil = -Sgn(number) * Int(-Abs(number)) End Function Vielen Dank
und Grüße aus Kunduz
Alex