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

[moishy]

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

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

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

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

 

[דוד דוד]

התקיה הזו אינה נפתחת, אודה לך מאד אם תעלה את הקובץ שוב.

 

[moishy]

התקיה הזו אינה נפתחת, אודה לך מאד אם תעלה את הקובץ שוב.

זה קובץ דחוס, פתח אותו באמצעות תוכנת דחיסה.

 

[חדש ומחודש]

קוד נקי ומקצועי. נכתב ע"י 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