אופיס 365 גיל מתאריך עברי

[שחר עולה]

אני לא יודעת אם זה מתאים לפורום הזה, אבל יש לי שאלה: אולי משהו יודע אם יש אפשרות לחשב בנוסחא גיל לפי תאריך עברי באקסל?

 

[FullTime]

...

 

[grafix]

השאלה לא מובנת...

 

[שחר עולה]

...

?????

 

[שחר עולה]

א.תודה על התגובה
ב. אני עורכת באקסל רשימה של המשפחה שלי ובין יתר הנתונים יש את תאריכים הלידה העבריים של האנשים, ואני מחפשת נוסחה שתמצא לי אוטומטית את הגיל שלהם...

עכשיו מובן???

 

[moishy]

בנוסחה לבד זה קשה מאוד מאוד עד בלתי אפשרי.
כמדומה שיש תוסף אקסל+ הנותן אפשרות כזו.

 

[שחר עולה]

בנוסחה לבד זה קשה מאוד מאוד עד בלתי אפשרי.
כמדומה שיש תוסף אקסל+ הנותן אפשרות כזו.

איך אני יכולה להשיג את התוסף הזה?

 

[FullTime]

בנוסחה לבד זה קשה מאוד מאוד עד בלתי אפשרי.
כמדומה שיש תוסף אקסל+ הנותן אפשרות כזו.

זה מה שכתבתי בהודעה הראשונה שלי.....
אבל, אחרי הכתיבה נזכרתי שבאקסל+ הופך מלועזי לעברי....

מה שכן, אחרי שתגמרו את הכל, תוכלו להעלות לכאן קובץ עם התאריכים לבד.
ומישהו שיש לו את האפשרות של המרת תאריכים באקסס, יוכל להמיר את זה בכמה דקות.

מוישי היקר העלה בעבר כו"כ פעמים קוד באקסס לזה..

 

[FullTime]

השאלה לא מובנת...

דוקא מובנת מאוד.

 

[שחר עולה]

אני עדיין לא הבנתי איך אני הופכת את התאריך העברי ללועזי או יותר נכון איך אני מוציאה מתאריך עברי - גיל
אני אשמח אם תעזרו לי...

 

[FullTime]

מתאריך עברי גיל, אין אפשרות למצוא.
מה שצריך לעשות, זה להפוך את התאריך העברי ללועזי, ואז אפשר לחשב את הגיל.
הפתרון הוא פונקציה שממירה את זה.
ועכשיו תקראו מההתחלה.

 

[חמוץ מתוק]

אני לא יודעת אם זה יעזור לך, אבל מצורץ תוסף להחלת תאריך עברי באקסס.

 

[שחר עולה]

אני לא יודעת אם זה יעזור לך, אבל מצורץ תוסף להחלת תאריך עברי באקסס.

אני אנסה לשחק בזה, אבל בכל אופן תודדדדדההההה לכ-ו-ל-כ-ם, לא ציפתי שכל כך ירצו לעזור לי....

 

[שמח לעזור]

אל תנסי לשחק כי זה לא יעזור לך...
הפורמט של התאריך הוא עקבי? תוכלי לכתוב פה דוגמה לתאריכים?

 

[moishy]

הנה קוד קצר המחזיר את הגיל לפי תאריך עברי:

Option Explicit

Public Function GetAgeFromHebDate(strHebDate As String) As String
    If IsValidHebDate(strHebDate) Then
        GetAgeFromHebDate = ExactAge(HebToDate(strHebDate))
    Else
        GetAgeFromHebDate = "תאריך עברי לא תקין!"
    End If
End Function

וזה הקוד הנצרך להפעלת הפונקציה הנ"ל:

Public Function ExactAge(varBirthDate As Variant) As String

    Dim lngYear As Long, lngMonth As Long, lngDay As Long
    Dim dtBirthDate As Date

    If Not IsDate(varBirthDate) Then Exit Function
    dtBirthDate = CDate(varBirthDate)
    
    If dtBirthDate = Date Then
        ExactAge = "היום יום הולדת, היום יום הולדת, היום יום הולדת ל..."
        Exit Function
    End If
    
    lngYear = Year(dtBirthDate)
    lngMonth = Month(dtBirthDate)
    lngDay = Day(dtBirthDate)
    lngYear = Year(Date) - lngYear
    lngMonth = Month(Date) - lngMonth
    lngDay = Day(Date) - lngDay

    If Sgn(lngDay) = -1 Then
        lngDay = 30 - Abs(lngDay)
        lngMonth = lngMonth - 1
    End If

    If Sgn(lngMonth) = -1 Then
        lngMonth = 12 - Abs(lngMonth)
        lngYear = lngYear - 1
    End If
    
    ExactAge = IIf(lngYear > 1, lngYear & " שנים ", IIf(lngYear = 1, " שנה ", "")) & _
               IIf(lngMonth > 1, lngMonth & " חודשים ", IIf(lngMonth = 1, " חודש אחד", "")) & _
               IIf(lngDay > 1, " ו" & lngDay & " ימים ", IIf(lngDay = 1, " יום אחד ", ""))

End Function

Public Function HebToDate(Optional strDate As String)

    Dim arrString() As String
    Dim nYearH As Long
    Dim nMonthH As Long
    Dim nDateH As Long
    Dim i As Integer, iCounter As Integer

    If IsNothing(strDate) Then strDate = TodayHeb

    If Not IsValidHebDate(strDate) Then
        HebToDate = ""
        Exit Function
    End If

    arrString = fParseHebDate(strDate)

    nYearH = CLng(arrString(2))
    nMonthH = CLng(arrString(1))
    nDateH = CLng(arrString(0))

    HebToDate = HebToGreg(nYearH, nMonthH, nDateH)

End Function

Function IsValidHebDate(strDate As String)

    Dim strHebDay As String, strHebMonth As String, strHebYear As String

    Dim i As Integer, iCounter As Integer
    Dim arrDateString() As String

    If strDate = "" Then Exit Function

    ' Remove double-quotes and aphostrophes
    If InStr(1, strDate, "'") > 0 Then strDate = Replace(strDate, "'", "")
    If InStr(1, strDate, Chr(34)) > 0 Then strDate = Replace(strDate, Chr(34), "")

    If Not IsDate(strDate) Then

        arrDateString = Split(strDate, " ")

        ' Remove leading "ב" in month name
        Select Case UBound(arrDateString)
            Case Is = 2
                If Left(arrDateString(1), 1) = "ב" Then
                    strDate = arrDateString(0) & " " & Right(arrDateString(1), Len(arrDateString(1)) - 1) & " " & arrDateString(UBound(arrDateString))
                Else
                    strDate = arrDateString(0) & " " & arrDateString(1) & " " & arrDateString(UBound(arrDateString))
                End If
            Case Is = 3
                If Left(arrDateString(1), 1) = "ב" Then
                    strDate = arrDateString(0) & " " & Right(arrDateString(1), Len(arrDateString(1)) - 1) & " " & Trim(Mid(strDate, InStr(1, strDate, " "), Len(strDate) - InStr(4, StrReverse(strDate), " ") - 1))
                Else
                    strDate = arrDateString(0) & " " & arrDateString(1) & " " & Trim(Mid(strDate, InStr(1, strDate, " "), Len(strDate) - InStr(4, StrReverse(strDate), " ") - 1))
                End If
        End Select

        ' Check #1 - Contains only Hebrew chars and spaces
        For i = 1 To Len(strDate)
            If Asc(Mid(strDate, i, 1)) = 32 Or Asc(Mid(strDate, i, 1)) > 223 And Asc(Mid(strDate, i, 1)) < 251 Then
            Else
                IsValidHebDate = False
                Exit Function
            End If
        Next i

        ' Check #2 - Contains at least 2 spaces, meaning there are 3 words; day, month, year
        If UBound(arrDateString) < 2 Then
            IsValidHebDate = False
            Exit Function
        End If

        ' Extract separate elements of date
        strHebDay = arrDateString(0)
        strHebMonth = Trim(Mid(strDate, InStr(1, strDate, " "), Len(strDate) - InStr(4, StrReverse(strDate), " ") - 1))
        strHebYear = arrDateString(UBound(arrDateString))

        ' Check #3 - not אדר ב in a non leap year
        If Not IsLeapYear(fReverseGimatria(strHebYear)) Then
            If InStr(1, strHebMonth, " ") > 0 Then
                IsValidHebDate = False
                Exit Function
            End If
            If InStr(1, strHebMonth, "-") > 0 Then
                IsValidHebDate = False
                Exit Function
            End If
        End If

        ' Check #4 - Final Check - day is smaller than day after last day of month
        Select Case IsFullMonth(fReverseGimatria(strHebYear) + 5000, fGetHebMonthNumber(strHebMonth))
            Case 1    ' full month
                IsValidHebDate = fReverseGimatria(strHebDay) < 31
            Case 2    ' not full month
                IsValidHebDate = fReverseGimatria(strHebDay) < 30
            Case 0    ' not valid date
                IsValidHebDate = False
        End Select
    Else
        IsValidHebDate = False
    End If

End Function

Function DateType(strDate As String) As Integer

' 0 = Not a Date, 1 = Gregorian Date, 2 = Hebrew Date

    If IsValidHebDate(strDate) Then
        DateType = 2
    ElseIf IsDate(strDate) Then
        DateType = 1
    Else
        DateType = 0
    End If

End Function

Function IsFullMonth(nYearH As Long, nMonthH As Long) As Integer

' 0 = Not Valid, 1 = Full Month, 2 = Not Full Month

    If nMonthH < 1 Or nMonthH > 13 And nYearH < 4000 And nYearH > 6000 Then
        IsFullMonth = 0
    Else
        If Not IsLeapYear(nYearH) And nMonthH = 7 Then Exit Function
        IsFullMonth = IIf(DateDiff("d", CStr(HebToGreg(nYearH, nMonthH, 1)), CStr(HebToGreg(nYearH, nMonthH + 1, 1))) = 30, 1, 2)
    End If

End Function

Function NextHebrewWorkday(strDate As String) As String

    Dim arrString() As String
    Dim strTemp As String
    Dim i As Integer

    Select Case DateType(strDate)
        Case 0
            NextHebrewWorkday = ""
        Case 1
            NextHebrewWorkday = Format(strDate, "DD/MM/YYYY")
            i = 1
            Do Until fIsSabbathOrHoliday(NextHebrewWorkday) = False
                NextHebrewWorkday = Format(DatePart("d", strDate) + i & "/" & DatePart("m", strDate) & "/" & DatePart("yyyy", strDate), "DD/MM/YYYY")
                i = i + 1
            Loop
        Case 2
            arrString = fParseHebDate(strDate)
            NextHebrewWorkday = FormatDateH(CLng(arrString(2)), CLng(arrString(1)), CLng(arrString(0)))
            If Not fIsSabbathOrHoliday(HebToDate(NextHebrewWorkday)) Then
                NextHebrewWorkday = FormatDateH(CLng(arrString(2)), CLng(arrString(1)), CLng(arrString(0)))
            Else
                i = 1
                Do Until fIsSabbathOrHoliday(HebToDate(NextHebrewWorkday)) = False
                    NextHebrewWorkday = FormatDateH(CLng(arrString(2)), CLng(arrString(1)), CLng(arrString(0) + i))
                    i = i + 1
                Loop
                NextHebrewWorkday = FormatDateH(CLng(arrString(2)), CLng(arrString(1)), CLng(arrString(0) + 1))
            End If
    End Select

End Function

Function fIsSabbathOrHoliday(ByVal dtGregDate As Date, _
                             Optional blnHolidaysOnly As Boolean = False, _
                             Optional ByVal blnEretzYisroel As Boolean = True) _
                             As Boolean

    Dim HebMonthNumber As Integer, HebDayNumber As Integer
    Dim nYearH As Long, nMonthH As Long, nDateH As Long

    If Not blnHolidaysOnly Then
        If Weekday(dtGregDate) = 7 Then
            fIsSabbathOrHoliday = True
            Exit Function
        End If
    End If

    Call GregToHeb(dtGregDate, 0, nMonthH, nDateH)

    HebMonthNumber = nMonthH
    HebDayNumber = nDateH

    Select Case HebMonthNumber * 100 + HebDayNumber
        Case 101
            fIsSabbathOrHoliday = True    ' "א דראש השנה"
        Case 102
            fIsSabbathOrHoliday = True    ' "ב דראש השנה"
        Case 110
            fIsSabbathOrHoliday = True    ' "יום הכיפורים"
        Case 115
            fIsSabbathOrHoliday = True    ' "סוכות"
        Case 116
            If Not blnEretzYisroel Then
                fIsSabbathOrHoliday = True
            End If
        Case 122
            fIsSabbathOrHoliday = True    ' "שמיני עצרת"
        Case 123
            If Not blnEretzYisroel Then
                fIsSabbathOrHoliday = True
            End If
        Case 715
            fIsSabbathOrHoliday = True    ' "פסח"
        Case 716
            If Not blnEretzYisroel Then
                fIsSabbathOrHoliday = True
            End If
        Case 721
            fIsSabbathOrHoliday = True    ' "שביעי של פסח"
        Case 722
            If Not blnEretzYisroel Then
                fIsSabbathOrHoliday = True
            End If
        Case 906
            fIsSabbathOrHoliday = True    ' "שבועות"
        Case 907
            If Not blnEretzYisroel Then
                fIsSabbathOrHoliday = True
            End If
    End Select

End Function

Function DateToLong(ByVal dt As Date) As Long
    DateToLong = CLng(dt)
End Function

Public Function GregToHeb(ByVal dGreg As Date, _
                          ByRef nYearH As Long, _
                          ByRef nMonthH As Long, _
                          ByRef nDateH As Long) As String

    Dim nOneMolad As Double
    Dim nAvrgYear As Double
    Dim nDays As Long
    Dim dTishrei1 As Date
    Dim nLengthOfYear As Long
    Dim bLeap As Boolean
    Dim bHaser As Boolean
    Dim bShalem As Boolean
    Dim nMonthLen As Long
    Dim bWhile As Boolean


    nOneMolad = 29 + (12 / 24) + (793 / (1080 * 24))

    nAvrgYear = nOneMolad * (235 / 19)

    nDays = dGreg - #1/1/1900#
    nDays = nDays + 2067025

    nYearH = Int(CDbl(nDays) / nAvrgYear) + 1

    dTishrei1 = Tishrei1(nYearH)
    If dTishrei1 = dGreg Then

        nMonthH = 1
        nDateH = 1
    Else

        If dTishrei1 < dGreg Then

            Do While Tishrei1(nYearH + 1) <= dGreg
                nYearH = nYearH + 1
            Loop
        Else

            nYearH = nYearH - 1
            Do While Tishrei1(nYearH) > dGreg
                nYearH = nYearH - 1
            Loop
        End If

        nDays = dGreg - Tishrei1(nYearH)

        nLengthOfYear = LengthOfYear(nYearH)
        bHaser = nLengthOfYear = 353 Or nLengthOfYear = 383
        bShalem = nLengthOfYear = 355 Or nLengthOfYear = 385
        bLeap = IsLeapYear(nYearH)

        nMonthH = 1
        Do
            Select Case nMonthH
                Case 1, 5, 8, 10, 12
                    nMonthLen = 30
                Case 4, 7, 9, 11, 13
                    nMonthLen = 29
                Case 6
                    nMonthLen = 30
                Case 2
                    nMonthLen = IIf(bShalem, 30, 29)
                Case 3
                    nMonthLen = IIf(bHaser, 29, 30)
            End Select
            If nDays >= nMonthLen Then
                bWhile = True
                If bLeap Or nMonthH <> 5 Then
                    nMonthH = nMonthH + 1
                Else

                    nMonthH = nMonthH + 2
                End If
                nDays = nDays - nMonthLen
            Else
                bWhile = False
            End If
        Loop While bWhile

        nDateH = nDays + 1
    End If
    GregToHeb = CStr(nMonthH) & "/" & CStr(nDateH) & "/" & CStr(nYearH)
End Function

Public Function HebToGreg(ByVal nYearH As Long, _
                          ByVal nMonthH As Long, _
                          ByVal nDateH As Long) As Date

    Dim nLengthOfYear As Long
    Dim bLeap As Boolean
    Dim dGreg As Date
    Dim nMonth As Long
    Dim nMonthLen As Long
    Dim bHaser As Boolean
    Dim bShalem As Boolean

    bLeap = IsLeapYear(nYearH)
    nLengthOfYear = LengthOfYear(nYearH)

    bHaser = nLengthOfYear = 353 Or nLengthOfYear = 383
    bShalem = nLengthOfYear = 355 Or nLengthOfYear = 385

    dGreg = Tishrei1(nYearH)

    For nMonth = 1 To nMonthH - 1
        Select Case nMonth
            Case 1, 5, 8, 10, 12
                nMonthLen = 30
            Case 4, 7, 9, 11, 13
                nMonthLen = 29
            Case 6
                nMonthLen = IIf(bLeap, 30, 0)
            Case 2
                nMonthLen = IIf(bShalem, 30, 29)
            Case 3
                nMonthLen = IIf(bHaser, 29, 30)
        End Select
        dGreg = dGreg + nMonthLen
    Next
    dGreg = dGreg + (nDateH - 1)
    HebToGreg = dGreg
End Function

Public Function IsLeapYear(ByVal nYearH As Long) As Boolean
    Dim nYearInCycle As Long

    nYearInCycle = nYearH Mod 19
    IsLeapYear = nYearInCycle = 3 Or _
                 nYearInCycle = 6 Or _
                 nYearInCycle = 8 Or _
                 nYearInCycle = 11 Or _
                 nYearInCycle = 14 Or _
                 nYearInCycle = 17 Or _
                 nYearInCycle = 0
End Function

Public Function LengthOfYear(ByVal nYearH As Long) As Long

    Dim dThisTishrei1 As Date
    Dim dNextTishrei1 As Date
    Dim diff As Long

    dThisTishrei1 = Tishrei1(nYearH)
    dNextTishrei1 = Tishrei1(nYearH + 1)
    diff = dNextTishrei1 - dThisTishrei1
    LengthOfYear = diff
End Function

Public Function MonSinceFirstMolad(ByVal nYearH As Long) As Long
    Dim nMonSinceFirstMolad As Long

    nYearH = nYearH - 1

    nMonSinceFirstMolad = Int(nYearH / 19) * 235

    nYearH = nYearH Mod 19

    nMonSinceFirstMolad = nMonSinceFirstMolad + (12 * nYearH)

    If nYearH >= 17 Then
        nMonSinceFirstMolad = nMonSinceFirstMolad + 6
    ElseIf nYearH >= 14 Then
        nMonSinceFirstMolad = nMonSinceFirstMolad + 5
    ElseIf nYearH >= 11 Then
        nMonSinceFirstMolad = nMonSinceFirstMolad + 4
    ElseIf nYearH >= 8 Then
        nMonSinceFirstMolad = nMonSinceFirstMolad + 3
    ElseIf nYearH >= 6 Then
        nMonSinceFirstMolad = nMonSinceFirstMolad + 2
    ElseIf nYearH >= 3 Then
        nMonSinceFirstMolad = nMonSinceFirstMolad + 1
    End If
    MonSinceFirstMolad = nMonSinceFirstMolad
End Function

Public Function Tishrei1(ByVal nYearH As Long) As Date
    Dim nMonthsSinceFirstMolad As Long
    Dim nChalakim As Long
    Dim nHours As Long
    Dim nDays As Long
    Dim nDayOfWeek As Long
    Dim dTishrei1 As Date

    nMonthsSinceFirstMolad = MonSinceFirstMolad(nYearH)
    nChalakim = 793 * nMonthsSinceFirstMolad
    nChalakim = nChalakim + 204

    nHours = Int(nChalakim / 1080)
    nChalakim = nChalakim Mod 1080

    nHours = nHours + (nMonthsSinceFirstMolad * 12)
    nHours = nHours + 5

    nDays = Int(nHours / 24)
    nHours = nHours Mod 24

    nDays = nDays + (29 * nMonthsSinceFirstMolad)
    nDays = nDays + 2

    nDayOfWeek = nDays Mod 7

    If Not IsLeapYear(nYearH) And _
       nDayOfWeek = 3 And _
       (nHours * 1080) + nChalakim >= _
       (9 * 1080) + 204 Then

        nDayOfWeek = 5
        nDays = nDays + 2
    ElseIf IsLeapYear(nYearH - 1) And _
           nDayOfWeek = 2 And _
           (nHours * 1080) + nChalakim >= _
           (15 * 1080) + 589 Then

        nDayOfWeek = 3
        nDays = nDays + 1
    Else

        If nHours >= 18 Then
            nDayOfWeek = nDayOfWeek + 1
            nDayOfWeek = nDayOfWeek Mod 7
            nDays = nDays + 1
        End If

        If nDayOfWeek = 1 Or _
           nDayOfWeek = 4 Or _
           nDayOfWeek = 6 Then
            nDayOfWeek = nDayOfWeek + 1
            nDayOfWeek = nDayOfWeek Mod 7
            nDays = nDays + 1
        End If
    End If

    nDays = nDays - 2067025
    dTishrei1 = #1/1/1900#
    dTishrei1 = dTishrei1 + nDays
    Tishrei1 = dTishrei1
End Function

Public Function FormatDateH(nYearH As Long, nMonthH As Long, nDateH)
    Dim sMonth As String
    sMonth = "ב" & fGetHebMonthName(nMonthH, nYearH)
    FormatDateH = CStr(fGimatria(nDateH)) & " " & sMonth & " " & CStr(fGimatria(nYearH))
End Function

Public Function fParseHebDate(strDate As String)

    Dim arrString() As String

    On Error Resume Next

    ' הסרת הגרשיים מהיום בחודש אם קיים
    If InStr(1, strDate, "'") > 0 Then strDate = Replace(strDate, "'", "")
    If InStr(1, strDate, Chr(34)) > 0 Then strDate = Replace(strDate, Chr(34), "")

    arrString = Split(strDate, " ")

    ' הסרת האות ב מתחילת החודש אם קיים
    If Left(arrString(1), 1) = "ב" Then
        arrString(1) = Right(arrString(1), Len(arrString(1)) - 1)
    End If

    If UBound(arrString) = 3 Then
        arrString(1) = arrString(1) & " " & arrString(2)
        arrString(2) = arrString(3)
        ReDim Preserve arrString(3)
    End If

    arrString(0) = fReverseGimatria(arrString(0))
    arrString(1) = fGetHebMonthNumber(arrString(1))
    arrString(2) = fReverseGimatria(arrString(2)) + 5000

    fParseHebDate = arrString

End Function

Public Function fGetHebMonthNumber(strMonthName As String) As Long

' הסרת האות ב מתחילת החודש אם קיים
    If Left(strMonthName, 1) = "ב" Then
        strMonthName = Right(strMonthName, Len(strMonthName) - 1)
    End If

    Select Case strMonthName
        Case Is = "תשרי"
            fGetHebMonthNumber = 1
        Case Is = "חשון", "חשוון", "מרחשון", "מרחשוון", "מר-חשון", "מר-חשוון"
            fGetHebMonthNumber = 2
        Case Is = "כסלו", "כסליו"
            fGetHebMonthNumber = 3
        Case Is = "טבת"
            fGetHebMonthNumber = 4
        Case Is = "שבט"
            fGetHebMonthNumber = 5
        Case Is = "אדר א", "אדר א'", "אדר ראשון", "אדר-ראשון", "אדר"
            fGetHebMonthNumber = 6
        Case Is = "אדר ב", "אדר ב'", "אדר שני", "אדר-שני"
            fGetHebMonthNumber = 7
        Case Is = "ניסן"
            fGetHebMonthNumber = 8
        Case Is = "אייר", "איר"
            fGetHebMonthNumber = 9
        Case Is = "סיון", "סיוון"
            fGetHebMonthNumber = 10
        Case Is = "תמוז"
            fGetHebMonthNumber = 11
        Case Is = "אב", "מנחם אב"
            fGetHebMonthNumber = 12
        Case Is = "אלול"
            fGetHebMonthNumber = 13
        Case Else
            fGetHebMonthNumber = 0
    End Select
End Function

Public Function fGetHebMonthName(lngMonthNumber As Long, lngYearNumber As Long) As String

    Select Case lngMonthNumber
        Case 1
            fGetHebMonthName = "תשרי"
        Case 2
            fGetHebMonthName = "חשון"
        Case 3
            fGetHebMonthName = "כסלו"
        Case 4
            fGetHebMonthName = "טבת"
        Case 5
            fGetHebMonthName = "שבט"
        Case 6
            fGetHebMonthName = IIf(IsLeapYear(lngYearNumber), "אדר א", "אדר")
        Case 7
            fGetHebMonthName = "אדר ב"
        Case 8
            fGetHebMonthName = "ניסן"
        Case 9
            fGetHebMonthName = "אייר"
        Case 10
            fGetHebMonthName = "סיון"
        Case 11
            fGetHebMonthName = "תמוז"
        Case 12
            fGetHebMonthName = "אב"
        Case 13
            fGetHebMonthName = "אלול"
    End Select
End Function


' Hebrew Date Conversion Utilities
'
'.החזר את המספר באופן גימטרי באותיות
'הפונקציה רקורסיבית כדי לכלול ערכים הגדולים
'או שווים לאלף
'יש בו 4 ארגומנטים:
' 1. המספר המבוקש
' 2. האם לכלול אלפים (כגון ה'תשע"ג) (כן/לא) ברירת המחדל היא לא
' 3. האם לכלול גרשיים (כגון תשע"ג) (כן/לא) ברירת המחדל היא כן
' 4. האם להשתמש במספרים "נקיים" (כגון ערה במקום רעה) (כן/לא) ברירת המחדל היא כן

Public Function fGimatria(ByVal intNum As Integer, _
                          Optional blnIncludeThousands As Boolean = False, _
                          Optional blnIncludeQuotes As Boolean = True, _
                          Optional blnInludeSingleQuote As Boolean = True, _
                          Optional blnGoodNumbers As Boolean = True) As String

'intNum - מספר שלם להמרה
    Dim strTemp As String
    Dim Digit As Integer

    strTemp = ""

    'אם המספר גדול (או שווה) לאלף, מצא את הגימטריה של
    'החלוקה השלמה של המספר באלף
    If intNum >= 1000 Then
        strTemp = fGimatria(intNum \ 1000)
        intNum = intNum Mod 1000
        If Right$(strTemp, 1) <> Chr$(39) Then
            strTemp = strTemp & Chr$(39)    ' הוספת גרש אחר אות האלפים
        End If
    End If

    'ספרת המאות
    'אם המספר גדול או שווה ל-900
    'הוסף קדומת של האותיות תתק
    If intNum >= 900 Then strTemp = strTemp & "תתק"

    'אם המספר גדול או שווה ל-500, הוסף קדומת של
    'האות ת' ואות נוספת בין ק-ת
    If intNum >= 500 And intNum < 900 Then
        strTemp = strTemp + "ת"
        strTemp = strTemp + Chr$(Asc("ק") + (intNum \ 100 - 5))
    End If

    'אם המספר גדול מ-100 הוסף אות בין ק-ת
    If intNum >= 100 And intNum < 500 Then
        strTemp = strTemp + Chr$(Asc("ק") + (intNum \ 100 - 1))
    End If

    'ספרת העשרות
    'אם המספר ללא מאות גדול מ-10 הוסף את האות המתאימה
    Digit = (intNum Mod 100) \ 10
    If Digit Then
        Select Case Digit    'הספרה
            Case 1
                strTemp = strTemp + "י"
            Case 2
                strTemp = strTemp + "כ"
            Case 3
                strTemp = strTemp + "ל"
            Case 4
                strTemp = strTemp + "מ"
            Case 5 To 7
                strTemp = strTemp + Chr$(Asc("נ") + Digit - 5)
            Case 8
                strTemp = strTemp + "פ"
            Case 9
                strTemp = strTemp + "צ"
        End Select
    End If

    'אם יש ספרת אחדות הוסף אותה
    Digit = (intNum Mod 10)
    If Digit Then strTemp = strTemp + Chr$(Asc("א") + Digit - 1)

    'מנע יה ויו
    '
    ' אין טעם להשתמש עם "Replace" אם אין וודאות שימצא הטקסט להחלפה
    ' מכיון שפונקציה זו תמיד מעתיקה את המחרוזת גם אם אין מה להחליף
    ' והעתקה זו איטית
    ' לכן קודם נשתמש עם "InStr" ורק אם נמצא  הטקסט להחלפה נקרא ל"Replace"
    If InStr(strTemp, "יה") <> 0 Then strTemp = Replace(strTemp, "יה", "טו")
    If InStr(strTemp, "יו") <> 0 Then strTemp = Replace(strTemp, "יו", "טז")

    If blnGoodNumbers Then
        ' משנה שנים "רעות" לנקיות
        strTemp = Replace(strTemp, "רצח", "רחצ")
        strTemp = Replace(strTemp, "רע", "ער")
        strTemp = Replace(strTemp, "רעה", "ערה")
        strTemp = Replace(strTemp, "שד", "דש")
        strTemp = Replace(strTemp, "שמד", "דשמ")
    End If

    If blnIncludeQuotes Then
        ' הוספת גרשיים לפני האות האחרונה אם יש יותר משני תווים במחרוזת
        If Len(strTemp) > 1 Then
            If Right$(strTemp, 1) <> Chr$(39) Then
                strTemp = Mid$(strTemp, 1, Len(strTemp) - 1) & Chr$(34) & Mid$(strTemp, Len(strTemp), 1)
            End If
        End If
    End If

    If Not blnIncludeThousands Then
        ' מוריד את האות המסמל את האלפים
        If InStr(strTemp, "'") Then
            If Len(strTemp) > 2 Then
                strTemp = Right$(strTemp, Len(strTemp) - 2)
            End If
        End If
    End If

    If blnInludeSingleQuote Then
        If Len(strTemp) = 1 Then
            If Right$(strTemp, 1) <> Chr$(39) Then
                strTemp = strTemp & Chr$(39)
            End If
        End If
    End If

    ' מחזיר את התוצאה הסופית
    fGimatria = strTemp

End Function

Public Function fReverseGimatria(strLetters As String) As Long
'פרוצדורה זו מוצאת עת הערך הכולל של הצירוף שניתן
'על ידי מציאת המיקום של האות בסדר האלפבתי

'משתנים בשביל שתי הלולאות
    Dim i As Integer, t As Integer
    'משתנה המכיל רק את האות הנבדקת כל פעם
    Dim Letter As String * 1
    'מכיל את הערך הגימטרי של אותה אות
    Dim GeLetter As Integer
    'מכיל את הערך הכולל של הצירוף שניתן
    Dim SumGeLetter As Integer
    'קבוע זה מכיל את כל האותיות לפי הסדר
    Const AllLetters = "אבגדהוזחטיכלמנסעפצקרשת"

    'לולאה ראשונה עוברת כל אות בצירוף שהוקלד
    For i = 1 To Len(strLetters)
        'מכניס למשתנה את האות הנוכחית
        Letter = Mid(strLetters, i, 1)

        'לולאה זו עוברת על כל אותיות האלף בית
        For t = 1 To Len(AllLetters)

            'בדיקה האם האות שנבדקת שווה לאות הנוכחית
            If Letter = Mid(AllLetters, t, 1) Then

                'עכשיו זה הקוד החשוב שעושה את הבדיקה עצמה

                If t <= 10 Then    'אם מיקום האות קטן או שווה לעשר המיקום בלי שום פעולה, אחדות
                    GeLetter = t
                ElseIf t > 10 And t <= 19 Then
                    'אם המיקום גדול מעשר וקטן מ20 אז המיקום מוחזר לאחדות ומוכפל בעשר, עשרות
                    GeLetter = (t - 9) * 10
                ElseIf t > 19 Then    'אם הוא גדול מ19 אז המספרים מוחזרים לאחדות ומוכפלים ב100, מאות
                    GeLetter = (t - 18) * 100
                End If

                'הערך מוסף לערך הכללי
                SumGeLetter = SumGeLetter + GeLetter

            End If

        Next t

    Next i
    'מכניס את הערך לתיבה
    fReverseGimatria = SumGeLetter

End Function


Public Function IsNothing(ByVal varValueToTest) As Integer
'-----------------------------------------------------------
' Does a "nothing" test based on data type.
'   Null = nothing
'   Empty = nothing
'   Number = 0 is nothing
'   String = "" is nothing
'   Date/Time is never nothing
' Inputs: A value to test for logical "nothing"
' Outputs: True = value passed is a logical "nothing", False = it ain't
' Created By: JLV 01/31/95
' Last Revised: JLV 01/31/95
'-----------------------------------------------------------
    Dim intSuccess As Integer

    On Error GoTo IsNothing_Err
    IsNothing = True

    Select Case VarType(varValueToTest)
        Case 0      ' Empty
            GoTo IsNothing_Exit
        Case 1      ' Null
            GoTo IsNothing_Exit
        Case 2, 3, 4, 5, 6  ' Integer, Long, Single, Double, Currency
            If varValueToTest <> 0 Then IsNothing = False
        Case 7      ' Date / Time
            IsNothing = False
        Case 8      ' String
            If (Len(varValueToTest) <> 0 And varValueToTest <> " ") Then IsNothing = False
    End Select


IsNothing_Exit:
    On Error GoTo 0
    Exit Function

IsNothing_Err:
    IsNothing = True
    Resume IsNothing_Exit

End Function

 

[FullTime]

וכאן יש את זה באקסל

 

[אפקטיביות]

עבודה יפה!
אם כי הגיל מחושב על פי שנים לועזיות, ולא ברור אם זה מה שהיה מבוקש.
אבל בהחלט מוצלח!

נ.ב. איך אפשר להכניס לאקסל XLS נוסחאות ושיישמר בפורמט זה? פתיחה בלי לאפשר הרשאות, סגירה מבלי לשאול על שמירת שינויים. האם זה פורמט אקסל רגיל או שעשית לו שינויים מסוימים??

 

[FullTime]

החל מאקסל 2010 יש סוג מיוחד של 'אקסל מאקרו' לקבצים עם קוד. [השלישי או הרביעי ב'שמור כסוג' שבחלון השמירה]
האקסל הזה שמור כ2003 ולכן זה לא בעיה.

 

[שחר עולה]

וכאן יש את זה באקסל

יווווווווווו זהה ממש טוב!!!!
זה עוזר לי מאוד, תודה רבה!!!
לa26955 ולכולם פה בפורום!!!

 

[FullTime]

יווווווווווו זהה ממש טוב!!!!
זה עוזר לי מאוד, תודה רבה!!!
לa26955 ולכולם פה בפורום!!!

תודה על הפרגון.
אבל העיקר חסר, הקוד הוא של מוישי, ולו נאה תהילה.