פונקציות לתאריך עברי

moishy

משתמש סופר מקצוען
מנוי פרימיום
בקובץ המצורף יש מספר פונקציות הקשורות לתאריך עברי. הפונקציות מתאימות לכל תוכנות מייקרוסופט אופיס, ולשאר התוכנו התומכות בVBA, למרות שהדוגמא המצורפת היא חוברת עבודה של אקסל.
המשמעותיות שבהן הינן:
TodayHeb תאריך עברי היום
DateToHeb המרת תאריך לועזי לתאריך עברי
HebToDate המרת תאריך עברי לתאריך לועזי
IsSabbathOrHoliday האם יום נתון הוא שבת או חג
IsValidHebDate בדיקת תקינות תאריך עברי
NextHebrewWorkday יום העבודה הבא, אם היום הנתון חל בשבת או חג

יש עוד מספר פונקציות כאשר יראה המתבונן.

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

נ.ב.
בעבר פורסמו כאן בפרורום שלש שיטות להמרת תאריכים, שיטת הAPI ה(לא כל כך) טובה והישנה, שיטת המבוססת על שימוש כבד במערכים שכתב AYG, ושיטה נוספת ארוכה ומסורבלת יותר, אך לדעתי הממחישה יותר את התהליך. זו השיטה המשמשת קובץ זה.
 

קבצים מצורפים

  • פונקציות תאריכים עבריים.zip
    KB 55.5 · צפיות: 602
נערך לאחרונה ב:

moishy

משתמש סופר מקצוען
מנוי פרימיום

moishy

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

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

דוד דוד

משתמש חדש
ל Moishy
סליחה על ההטרדה,
הקוד שלך יכול מאד לעזור לי, אך משום מה המחשב כותב לי הודעה שהתיקייה ריקה או אינה חוקית,
כפי הידוע לי ווינדוס 10 אמור לחלץ קובץ ZIP ללא תוכנה מיוחדת,
אודה לך מאד אם תפתור לי את הבעיה או שתעלה את הקובץ כשאינו מכווץ.
ושוב תודה, דוד
 

moishy

משתמש סופר מקצוען
מנוי פרימיום
ל Moishy
סליחה על ההטרדה,
הקוד שלך יכול מאד לעזור לי, אך משום מה המחשב כותב לי הודעה שהתיקייה ריקה או אינה חוקית,
כפי הידוע לי ווינדוס 10 אמור לחלץ קובץ ZIP ללא תוכנה מיוחדת,
אודה לך מאד אם תפתור לי את הבעיה או שתעלה את הקובץ כשאינו מכווץ.
ושוב תודה, דוד
זה לא קובץ zip זה קובץ rar.
 

דב פליי

משתמש פעיל
בקובץ המצורף יש מספר פונקציות הקשורות לתאריך עברי. הפונקציות מתאימות לכל תוכנות מייקרוסופט אופיס, ולשאר התוכנו התומכות בVBA, למרות שהדוגמא המצורפת היא חוברת עבודה של אקסל.
המשמעותיות שבהן הינן:
TodayHeb תאריך עברי היום
DateToHeb המרת תאריך לועזי לתאריך עברי
HebToDate המרת תאריך עברי לתאריך לועזי
IsSabbathOrHoliday האם יום נתון הוא שבת או חג
IsValidHebDate בדיקת תקינות תאריך עברי
NextHebrewWorkday יום העבודה הבא, אם היום הנתון חל בשבת או חג

יש עוד מספר פונקציות כאשר יראה המתבונן.

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

נ.ב.
בעבר פורסמו כאן בפרורום שלש שיטות להמרת תאריכים, שיטת הAPI ה(לא כל כך) טובה והישנה, שיטת המבוססת על שימוש כבד במערכים שכתב AYG, ושיטה נוספת ארוכה ומסורבלת יותר, אך לדעתי הממחישה יותר את התהליך. זו השיטה המשמשת קובץ זה.

תודה רבה על הקודים, שימח אותי מאד

אולי יש אפשרות לעשות פונקצייה לחישוב תאריך עברי קדימה בדומה לפונקצייה DateAdd של האקסס לחישוב תאריך לועזי קדימה ואחורה?
 

דוד דוד

משתמש חדש
ל Moishy הגאון
אצלחתי לפתוח וזה עובד לי מדהים!!
תודה רבה!
שאלה: ניסיתי להעתיק את הקוד לחוברת ראשית PERSONAL , כדי שלא אצטרך להעתיק את הקוד לכל חוברת עבודה,
ומשום מה זה לא עובד, בפקדות מאקרו זה עובד לי, ידוע לך האם זה אמור לעבוד גם בפונקציות?
 

moishy

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

אולי יש אפשרות לעשות פונקצייה לחישוב תאריך עברי קדימה בדומה לפונקצייה DateAdd של האקסס לחישוב תאריך לועזי קדימה ואחורה?
כבר קיימת בחוברת הנ"ל פונקציה כזאת להוספת חודשים לתאריך עברי.
אם כי למעשה, ניתן להמיר את התאריך העברי ללועזי, להשתמש עם dateadd, ושוב להמיר את התאריך הלועזי לעברי. כמובן ניתן להכניס את כל זה לפונקציה קטנה למען נוחות הישמוש.
 
נערך לאחרונה ב:

דב פליי

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

צודק, תודה איזה כיף!

איזה פרמטרים אני אמור לתת לפונקצייה HebrewDateAdd כתבתי לה תא מסוים וכמות חודשים קדימה והוא כתב לי שגיאה

אשמח לעזרה
 

moishy

משתמש סופר מקצוען
מנוי פרימיום
ל Moishy הגאון
אצלחתי לפתוח וזה עובד לי מדהים!!
תודה רבה!
שאלה: ניסיתי להעתיק את הקוד לחוברת ראשית PERSONAL , כדי שלא אצטרך להעתיק את הקוד לכל חוברת עבודה,
ומשום מה זה לא עובד, בפקדות מאקרו זה עובד לי, ידוע לך האם זה אמור לעבוד גם בפונקציות?
אכן, לא ניתן להשתמש בפונקציות בחוברת העבודה personal באופן המתבקש, אבל זה לא אומר שאין פתרון. 3 דרכים לפניך.
1. להקדים את שם חוברת העבודה שבה נמצא הקוד לשם הפונקציה. לדוגמה:
=personal.xlsb!TodayHed
2. לשמור את הקוד בקובץ תוסף בסיומת xlam
3. להוסיף הפניה לpersonal.xlsb מתוך רשימת ההפניות בעורך הקוד (VBE)
 

moishy

משתמש סופר מקצוען
מנוי פרימיום
צודק, תודה איזה כיף!

איזה פרמטרים אני אמור לתת לפונקצייה HebrewDateAdd כתבתי לה תא מסוים וכמות חודשים קדימה והוא כתב לי שגיאה

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

דב פליי

משתמש פעיל
הפונקצייה HebrewDateAdd נותנת תאריך עברי מספר חודשים קדימה ע"י קבלת תאריך לועזי,

אני התכוונתי להציע שיהא תאריך עברי קדימה ע"י קבלת תאריך עברי אחר
 

moishy

משתמש סופר מקצוען
מנוי פרימיום
הפונקצייה HebrewDateAdd נותנת תאריך עברי מספר חודשים קדימה ע"י קבלת תאריך לועזי,

אני התכוונתי להציע שיהא תאריך עברי קדימה ע"י קבלת תאריך עברי אחר
הילך...
קוד:
Option Explicit

Function HebDateAdd(strInterval As String, dblNumber As Double, strDate As String)

    ' הפונקציה מיועדת להוסיף מספר נתון של ימים או חודשים לתאריך נתון
    ' הפונקציה מחזירה תאריך עברי
    ' הארגומנטים הם:
    ' 1. סוג המרווח שרוצים להוסיף לתאריך, יש שתי אפשרויות, "י" = לימים ו"ח" = לחודשים
    ' 2. מספר המרווחים
    ' 3. התאריך עליו רוצים להוסיף
   
    Dim dtTemp As Date
   
    Dim lngHebYear As Long
    Dim lngHebMonth As Long
    Dim lngHebDay As Long
    Dim lngTotalMonths As Long
    Dim lngLengthOfYear As Long
    Dim blnLeapYear As Boolean
    Dim blnHaser As Boolean
    Dim blnShalem As Boolean
   
    Select Case DateType(strDate)
        Case 0
            ' לא תאריך
            HebDateAdd = ""
        Case 1
            ' תאריך לועזי
        Case 2
            ' תאריך עברי
            strDate = HebToDate(strDate)
    End Select
   
    Select Case strInterval
        Case Is = "י"
            strDate = DateAdd("d", dblNumber, strDate)
            HebDateAdd = DateToHeb(strDate)
            Exit Function
        Case Is = "ח"
            GoTo process
        Case Else
            HebDateAdd = ""
            Exit Function
    End Select
   
process:
           
    GregToHeb strDate, lngHebYear, lngHebMonth, lngHebDay
    lngLengthOfYear = LengthOfYear(lngHebYear)
    blnHaser = lngLengthOfYear = 353 Or lngLengthOfYear = 383
    blnShalem = lngLengthOfYear = 355 Or lngLengthOfYear = 385
    lngTotalMonths = dblNumber + lngHebMonth

    Do While lngTotalMonths > 13
        lngHebYear = lngHebYear + 1
        blnLeapYear = IsLeapYear(lngHebYear)
        lngTotalMonths = lngTotalMonths - IIf(blnLeapYear, 13, 12)
    Loop

    blnLeapYear = IsLeapYear(lngHebYear)

    If lngHebDay = 30 Then
        Select Case lngTotalMonths
            Case 1, 5, 8, 10, 12
                lngHebDay = 30
            Case 4, 7, 9, 11, 13
                lngHebDay = 1
                lngTotalMonths = IIf(lngTotalMonths = 13, 1, lngTotalMonths + 1)
                lngHebYear = IIf(lngTotalMonths > 13, lngHebYear + Int(lngTotalMonths / 13), lngHebYear)
            Case 6
            Case 2
                lngHebDay = IIf(Not blnShalem, 1, 30)
                lngHebMonth = IIf(Not blnShalem, lngHebMonth + 1, lngHebMonth)
            Case 3
                lngHebDay = IIf(blnHaser, 1, 30)
                lngHebMonth = IIf(blnHaser, lngHebMonth + 1, lngHebMonth)
        End Select
    End If

    HebDateAdd = FormatDateH(lngHebYear, lngTotalMonths, lngHebDay)
                   
End Function
 

דב פליי

משתמש פעיל
הילך...
קוד:
Option Explicit

Function HebDateAdd(strInterval As String, dblNumber As Double, strDate As String)

    ' הפונקציה מיועדת להוסיף מספר נתון של ימים או חודשים לתאריך נתון
    ' הפונקציה מחזירה תאריך עברי
    ' הארגומנטים הם:
    ' 1. סוג המרווח שרוצים להוסיף לתאריך, יש שתי אפשרויות, "י" = לימים ו"ח" = לחודשים
    ' 2. מספר המרווחים
    ' 3. התאריך עליו רוצים להוסיף
  
    Dim dtTemp As Date
  
    Dim lngHebYear As Long
    Dim lngHebMonth As Long
    Dim lngHebDay As Long
    Dim lngTotalMonths As Long
    Dim lngLengthOfYear As Long
    Dim blnLeapYear As Boolean
    Dim blnHaser As Boolean
    Dim blnShalem As Boolean
  
    Select Case DateType(strDate)
        Case 0
            ' לא תאריך
            HebDateAdd = ""
        Case 1
            ' תאריך לועזי
        Case 2
            ' תאריך עברי
            strDate = HebToDate(strDate)
    End Select
  
    Select Case strInterval
        Case Is = "י"
            strDate = DateAdd("d", dblNumber, strDate)
            HebDateAdd = DateToHeb(strDate)
            Exit Function
        Case Is = "ח"
            GoTo process
        Case Else
            HebDateAdd = ""
            Exit Function
    End Select
  
process:
          
    GregToHeb strDate, lngHebYear, lngHebMonth, lngHebDay
    lngLengthOfYear = LengthOfYear(lngHebYear)
    blnHaser = lngLengthOfYear = 353 Or lngLengthOfYear = 383
    blnShalem = lngLengthOfYear = 355 Or lngLengthOfYear = 385
    lngTotalMonths = dblNumber + lngHebMonth

    Do While lngTotalMonths > 13
        lngHebYear = lngHebYear + 1
        blnLeapYear = IsLeapYear(lngHebYear)
        lngTotalMonths = lngTotalMonths - IIf(blnLeapYear, 13, 12)
    Loop

    blnLeapYear = IsLeapYear(lngHebYear)

    If lngHebDay = 30 Then
        Select Case lngTotalMonths
            Case 1, 5, 8, 10, 12
                lngHebDay = 30
            Case 4, 7, 9, 11, 13
                lngHebDay = 1
                lngTotalMonths = IIf(lngTotalMonths = 13, 1, lngTotalMonths + 1)
                lngHebYear = IIf(lngTotalMonths > 13, lngHebYear + Int(lngTotalMonths / 13), lngHebYear)
            Case 6
            Case 2
                lngHebDay = IIf(Not blnShalem, 1, 30)
                lngHebMonth = IIf(Not blnShalem, lngHebMonth + 1, lngHebMonth)
            Case 3
                lngHebDay = IIf(blnHaser, 1, 30)
                lngHebMonth = IIf(blnHaser, lngHebMonth + 1, lngHebMonth)
        End Select
    End If

    HebDateAdd = FormatDateH(lngHebYear, lngTotalMonths, lngHebDay)
                  
End Function

תודה רבה! עובד מצוין!

עזר לי מאד מאד ! ישר כח!
 

דב פליי

משתמש פעיל
הילך...
קוד:
Option Explicit

Function HebDateAdd(strInterval As String, dblNumber As Double, strDate As String)

    ' הפונקציה מיועדת להוסיף מספר נתון של ימים או חודשים לתאריך נתון
    ' הפונקציה מחזירה תאריך עברי
    ' הארגומנטים הם:
    ' 1. סוג המרווח שרוצים להוסיף לתאריך, יש שתי אפשרויות, "י" = לימים ו"ח" = לחודשים
    ' 2. מספר המרווחים
    ' 3. התאריך עליו רוצים להוסיף
 
    Dim dtTemp As Date
 
    Dim lngHebYear As Long
    Dim lngHebMonth As Long
    Dim lngHebDay As Long
    Dim lngTotalMonths As Long
    Dim lngLengthOfYear As Long
    Dim blnLeapYear As Boolean
    Dim blnHaser As Boolean
    Dim blnShalem As Boolean
 
    Select Case DateType(strDate)
        Case 0
            ' לא תאריך
            HebDateAdd = ""
        Case 1
            ' תאריך לועזי
        Case 2
            ' תאריך עברי
            strDate = HebToDate(strDate)
    End Select
 
    Select Case strInterval
        Case Is = "י"
            strDate = DateAdd("d", dblNumber, strDate)
            HebDateAdd = DateToHeb(strDate)
            Exit Function
        Case Is = "ח"
            GoTo process
        Case Else
            HebDateAdd = ""
            Exit Function
    End Select
 
process:
         
    GregToHeb strDate, lngHebYear, lngHebMonth, lngHebDay
    lngLengthOfYear = LengthOfYear(lngHebYear)
    blnHaser = lngLengthOfYear = 353 Or lngLengthOfYear = 383
    blnShalem = lngLengthOfYear = 355 Or lngLengthOfYear = 385
    lngTotalMonths = dblNumber + lngHebMonth

    Do While lngTotalMonths > 13
        lngHebYear = lngHebYear + 1
        blnLeapYear = IsLeapYear(lngHebYear)
        lngTotalMonths = lngTotalMonths - IIf(blnLeapYear, 13, 12)
    Loop

    blnLeapYear = IsLeapYear(lngHebYear)

    If lngHebDay = 30 Then
        Select Case lngTotalMonths
            Case 1, 5, 8, 10, 12
                lngHebDay = 30
            Case 4, 7, 9, 11, 13
                lngHebDay = 1
                lngTotalMonths = IIf(lngTotalMonths = 13, 1, lngTotalMonths + 1)
                lngHebYear = IIf(lngTotalMonths > 13, lngHebYear + Int(lngTotalMonths / 13), lngHebYear)
            Case 6
            Case 2
                lngHebDay = IIf(Not blnShalem, 1, 30)
                lngHebMonth = IIf(Not blnShalem, lngHebMonth + 1, lngHebMonth)
            Case 3
                lngHebDay = IIf(blnHaser, 1, 30)
                lngHebMonth = IIf(blnHaser, lngHebMonth + 1, lngHebMonth)
        End Select
    End If

    HebDateAdd = FormatDateH(lngHebYear, lngTotalMonths, lngHebDay)
                 
End Function
שלום

ישנה שגיאה אם לדוגמא אני כותב לו "ל אב תשעח" כתאריך שעליו אני רוצה להוסיף ומרווח של חודש אחד קדימה הוא נותן "א תשרי תשעח" במקום "א תשרי תשעט"
אשמח לעזרה בתודה מראש
 

moishy

משתמש סופר מקצוען
מנוי פרימיום
שלום

ישנה שגיאה אם לדוגמא אני כותב לו "ל אב תשעח" כתאריך שעליו אני רוצה להוסיף ומרווח של חודש אחד קדימה הוא נותן "א תשרי תשעח" במקום "א תשרי תשעט"
אשמח לעזרה בתודה מראש
תשנה את הקוד הבא:
קוד:
    Do While lngTotalMonths > 13
        lngHebYear = lngHebYear + 1
        blnLeapYear = IsLeapYear(lngHebYear)
        lngTotalMonths = lngTotalMonths - IIf(blnLeapYear, 13, 12)
    Loop
לזה:
קוד:
    Do While lngTotalMonths > IIf(blnLeapYear, 13, 12)
        lngHebYear = lngHebYear + 1
        blnLeapYear = IsLeapYear(lngHebYear)
        lngTotalMonths = lngTotalMonths - IIf(blnLeapYear, 12, 11)
    Loop
 

דב פליי

משתמש פעיל
תשנה את הקוד הבא:
קוד:
    Do While lngTotalMonths > 13
        lngHebYear = lngHebYear + 1
        blnLeapYear = IsLeapYear(lngHebYear)
        lngTotalMonths = lngTotalMonths - IIf(blnLeapYear, 13, 12)
    Loop
לזה:
קוד:
    Do While lngTotalMonths > IIf(blnLeapYear, 13, 12)
        lngHebYear = lngHebYear + 1
        blnLeapYear = IsLeapYear(lngHebYear)
        lngTotalMonths = lngTotalMonths - IIf(blnLeapYear, 12, 11)
    Loop

תודה
עכשיו יש בעיה אחרת הוא עובר ל "ל תשרי תשעט" במקום ל "א תשרי תשעט"
נראה לי שמשהו משתבש כי הפונקצייה צריכה לדעת שני דברים 1 מעבר לשנה חדשה 2 חודש קדימה ואין ל בחודש כך שזה אמור לחודש הבא, ושנה הבאה ביחד, נסיתי לשנות את הפונקצייה על פי מה שהיה נראה לי הבעיה אבל לא הצלחתי
 

moishy

משתמש סופר מקצוען
מנוי פרימיום
תודה
עכשיו יש בעיה אחרת הוא עובר ל "ל תשרי תשעט" במקום ל "א תשרי תשעט"
נראה לי שמשהו משתבש כי הפונקצייה צריכה לדעת שני דברים 1 מעבר לשנה חדשה 2 חודש קדימה ואין ל בחודש כך שזה אמור לחודש הבא, ושנה הבאה ביחד, נסיתי לשנות את הפונקצייה על פי מה שהיה נראה לי הבעיה אבל לא הצלחתי
ומה תאמר על זה:
קוד:
Function HebDateAdd(strInterval As String, dblNumber As Double, strDate As String)

    Dim i As Long, lngDayCounter As Long
    Dim lngHebYear As Long, lngHebMonth As Long, lngHebDay As Long
    Dim strTempDate As String
    
    Select Case DateType(strDate)
        Case 0
            ' לא תאריך
            HebDateAdd = ""
        Case 1
            ' תאריך לועזי
        Case 2
            ' תאריך עברי
            strDate = HebToDate(strDate)
    End Select
    
    Select Case strInterval
        Case Is = "י"
            strDate = DateAdd("d", dblNumber, strDate)
            HebDateAdd = DateToHeb(strDate)
        Case Is = "ח"
            strDate = HebToDate(strDate)
            GregToHeb strDate, lngHebYear, lngHebMonth, lngHebDay
    
            For i = 1 To dblNumber
                lngDayCounter = lngDayCounter + IIf(IsFullMonth(lngHebYear, lngHebMonth + i), 30, 29)
            Next

            strTempDate = DateAdd("d", lngDayCounter, strDate)
            HebDateAdd = DateToHeb(strTempDate)
        Case Else
            HebDateAdd = ""
    End Select

End Function
 

אולי מעניין אותך גם...

הפרק היומי

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


תהילים פרק קיט ב'

ט בַּמֶּה יְזַכֶּה נַּעַר אֶת אָרְחוֹ לִשְׁמֹר כִּדְבָרֶךָ:י בְּכָל לִבִּי דְרַשְׁתִּיךָ אַל תַּשְׁגֵּנִי מִמִּצְוֹתֶיךָ:יא בְּלִבִּי צָפַנְתִּי אִמְרָתֶךָ לְמַעַן לֹא אֶחֱטָא לָךְ:יב בָּרוּךְ אַתָּה יְהוָה לַמְּדֵנִי חֻקֶּיךָ:יג בִּשְׂפָתַי סִפַּרְתִּי כֹּל מִשְׁפְּטֵי פִיךָ:יד בְּדֶרֶךְ עֵדְוֹתֶיךָ שַׂשְׂתִּי כְּעַל כָּל הוֹן:טו בְּפִקֻּדֶיךָ אָשִׂיחָה וְאַבִּיטָה אֹרְחֹתֶיךָ:טז בְּחֻקֹּתֶיךָ אֶשְׁתַּעֲשָׁע לֹא אֶשְׁכַּח דְּבָרֶךָ:
נקרא  10  פעמים

לוח מודעות

למעלה