אופיס 365 מאקרו להוספת תאריך עברי לצד תאריך לועזי

[vn453]

במסמך ארוך כתובים תאריכים רבים בצורות שונות, למשל:
2/7/2013
2.7.2013
02/7/2013
2.07.13
אני זקוק למאקרו שיאחד את כל המופעים השונים לפורמט 2.7.2013, יקיף את כל אחד מהם בסוגריים עגולים ויכתוב לפני כן את התאריך העברי הרלוונטי לתאריך, כך:
כ"ד בתמוז תשע"ג (2.7.2013)
אשמח לקבל סיוע.

 

[ayg]

מאקרו לתאריכים

הנה
להוסיף לתוך מאקרוס ולעשות לו קיצור דרך - והתיקייה המצורף להוסיף לתוך תיקייה הראשית של C
בכל פעם שיחלץ על הקיצור דרך יתעדכן התאריך הבא (ממקום הסמן) [לא עשיתי שיתקן כל הקובץ בבת אחת, כדי שתכול לבדוק האם מחלף כהגון]

Sub finddate()
A:
Set range1 = Selection.Range
range1.find.Execute findText:="^#", MatchWildcards:=False, Wrap:=wdFindStop
range1.MoveEndWhile cset:="1234567890./", Count:=wdForward
If InStr(1, range1, "/", 1) Or InStr(1, range1, ".", 1) Then
    range1.find.Execute findText:="/", MatchWildcards:=False, Wrap:=wdFindStop, ReplaceWith:=".", Replace:=wdReplaceAll
    'לסלק 0 ביום
    If Mid(range1.Text, 1, 1) = "0" Then range1.Text = Mid(range1.Text, 2, Len(range1.Text))
    'לסלק 0 בחודש
    If Mid(range1.Text, 2, 2) = ".0" Then range1.Text = Left(range1.Text, 2) & Mid(range1.Text, 4, Len(range1.Text))
    If Mid(range1.Text, 3, 2) = ".0" Then range1.Text = Left(range1.Text, 3) & Mid(range1.Text, 5, Len(range1.Text))
    'להוסיף 20 בשנה
    If Mid(range1.Text, Len(range1.Text) - 2, 1) = "." Then range1.Text = Left(range1.Text, Len(range1.Text) - 2) & "20" & Mid(range1.Text, Len(range1.Text) - 1, 2)
    temp1 = System.PrivateProfileString(FileName:="C:\macro\date_heb_eng.ini", Section:="date", Key:=range1.Text)
    If temp1 = "" Then MsgBox "לא מצא תאריך עברי"
    range1.Text = temp1 & " (" & range1.Text & "("
    range1.SetRange START:=range1.End, End:=range1.End
    range1.Select
Else
range1.SetRange START:=range1.End, End:=range1.End
range1.Select
GoTo A
End If
End Sub

צרפתי גם קובץ באקסל שאפשר בו להחליף בין תאריך לתאריך

הערות
1) סדר המספרים הוא כמו שכותבים בארץ קודם היום
2) מבחין בתאריך עברי א' תשרי תשס"ח עד כ"ט אלול תשצ"ט [אפשר להוסיף עוד תאריכים לתוך קובץ הini]
3) שנה שנכתב בשני מספרים נחשב כאולי הוא במאה ה20
4) כל מספור שיש בו .או/ נחשב כתאריך
אני מצפה שיהא לכם תועלות בזה

 

[vn453]

תודה רבה!

 

[ayg]

עדכון

עדכון
1) תיקון בעיה שהיה כשהסמן היה בסוף הקובץ
2) תיקון בעיה של המסגריים () כשהתאריך היה באנגלית

Sub finddate()
A:
Set range1 = Selection.Range
With range1.find: .Text = "^#": .MatchWildcards = False: .Wrap = wdFindStop: .Execute
If .Found = False Then MsgBox "אין עוד תאריכים": Exit Sub
End With
range1.MoveEndWhile cset:="1234567890./", Count:=wdForward
If InStr(1, range1, "/", 1) Or InStr(1, range1, ".", 1) Then
    range1.find.Execute findText:="/", MatchWildcards:=False, Wrap:=wdFindStop, ReplaceWith:=".", Replace:=wdReplaceAll
    'לסלק 0 ביום
    If Mid(range1.Text, 1, 1) = "0" Then range1.Text = Mid(range1.Text, 2, Len(range1.Text))
    'לסלק 0 בחודש
    If Mid(range1.Text, 2, 2) = ".0" Then range1.Text = Left(range1.Text, 2) & Mid(range1.Text, 4, Len(range1.Text))
    If Mid(range1.Text, 3, 2) = ".0" Then range1.Text = Left(range1.Text, 3) & Mid(range1.Text, 5, Len(range1.Text))
    'להוסיף 20 בשנה
    If Mid(range1.Text, Len(range1.Text) - 2, 1) = "." Then range1.Text = Left(range1.Text, Len(range1.Text) - 2) & "20" & Mid(range1.Text, Len(range1.Text) - 1, 2)
    temp1 = System.PrivateProfileString(FileName:="C:\macro\date_heb_eng.ini", Section:="date", Key:=range1.Text)
    range1.Text = "(" & range1.Text & ")"
    If temp1 = "" Then
        MsgBox "לא מצא תאריך עברי"
    Else
        range1.InsertBefore temp1 & " "
    End If
    range1.Select
    With Selection.find: .LanguageID = wdEnglishUS: .Replacement.LanguageID = wdHebrew: .Format = True: .Forward = True: .Wrap = wdFindStop: End With: Selection.find.Execute Replace:=wdReplaceAll
    With Selection.find: .ClearFormatting: .Replacement.ClearFormatting: End With
    range1.SetRange START:=range1.End, End:=range1.End: range1.Select
Else
    range1.SetRange START:=range1.End, End:=range1.End: range1.Select
    GoTo A
End If
End Sub

ראה כאן וכאן לעזרה האיך להכניס מאקרו

 

[moishy]

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

Option Explicit

Sub FinalTest()

    Dim oMatches As Object
    Dim oMatch As Object

    Dim RegExp As Object
    Set RegExp = CreateObject("VBScript.RegExp")

    With RegExp
        .Global = True
        .Pattern = "\d{1,2}[\/.-]\d{1,2}[\/.-]\d{2,4}"
        Set oMatches = .Execute(ActiveDocument.Range.text)

        For Each oMatch In oMatches
            If IsDate(oMatch) Then
                With Selection.Find
                    .ClearFormatting
                    .Replacement.ClearFormatting
                    .text = oMatch
                    .Replacement.text = GregToHeb(CDate(oMatch)) & " (" & oMatch & ")"
                    .Execute Replace:=wdReplaceOne
                    .Forward = False
                    .MatchCase = False
                    .MatchWholeWord = True
                End With
            End If
        Next
    End With
End Sub

Public Function GregToHeb(GrDate As Date, Optional DateString As String = "DDD MM YYYY") As Variant
'הפונקציה מחזירה תאריך עברי כביטוי טקסטואלי עבור תאריך גרגוריאני נתון
'הפונקציה מקבלת כפרמטרים תאריך עברי וביטוי טקסטואלי
'ומחזירה ביטוי שבו מצייני המקום מוחלפים ע"י רכיבי התאריך העברי כדלקמן
'D - יום בחודש בספרות
'DD - יום בחודש באותיות ללא גרשיים
'DDD - יום בחודש באותיות כולל גרשיים
'M - חודש בספרות: תשרי = 1, אדר = 6, אדר א = 6.1, אדר ב = 6.2
'MM - שם החודש במילים
'Y - שנה בספרות ללא אלפים
'YY - שנה בספרות כולל אלפים
'YYY - שנה באותיות, ללא אלפים, ללא גרשיים
'YYYY - שנה באותיות כולל גרשיים

'הפונקציה אינה רגישה לאותיות גדולות או קטנות
'מחרוזת ברירת המחדל היא: "DDD MM YYY"

    Dim prevRH, NextRH As Date
    Dim YearLen As Integer
    Dim DaysInYear As Integer
    Dim accMnthlen, MnthNames
    Dim MnthNum
    Dim WeekDayNames
    Dim strTemp As String
    Dim MM, DD, YY As Long
    Dim WW As Integer
    Dim CurMnthLen, PrevMnthLen

    WeekDayNames = Array("שבת", "ראשון", "שני", "שלישי", "רביעי", "חמישי", "ששי", "שבת")
    WW = Weekday(GrDate)

    strTemp = UCase(DateString)

    YY = Year(GrDate) + 3761
    prevRH = JRH(YY)
    If prevRH <= GrDate Then
        NextRH = JRH(YY + 1)
    Else
        NextRH = prevRH
        YY = YY - 1
        prevRH = JRH(YY)
    End If

    YearLen = NextRH - prevRH
    DaysInYear = GrDate - prevRH

    Select Case YearLen
        Case 353
            accMnthlen = Array(0, 30, 59, 88, 117, 147, 176, 206, 235, 265, 294, 324, 353)
        Case 354
            accMnthlen = Array(0, 30, 59, 89, 118, 148, 177, 207, 236, 266, 295, 325, 354)
        Case 355
            accMnthlen = Array(0, 30, 60, 90, 119, 149, 178, 208, 237, 267, 296, 326, 355)
        Case 383
            accMnthlen = Array(0, 30, 59, 88, 117, 147, 177, 206, 236, 265, 295, 324, 354, 383)
        Case 384
            accMnthlen = Array(0, 30, 59, 89, 118, 148, 178, 207, 237, 266, 296, 325, 355, 384)
        Case 385
            accMnthlen = Array(0, 30, 60, 90, 119, 149, 179, 208, 238, 267, 297, 326, 356, 385)
    End Select

    If YearLen < 380 Then
        MnthNames = Array("", "תשרי", "חשון", "כסלו", "טבת", "שבט", "אדר", "ניסן", "אייר", "סיון", "תמוז", "אב", "אלול")
        MnthNum = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
    Else
        MnthNames = Array("", "תשרי", "חשון", "כסלו", "טבת", "שבט", "אדר א", "אדר ב", "ניסן", "אייר", "סיון", "תמוז", "אב", "אלול")
        MnthNum = Array(0, 1, 2, 3, 4, 5, 6.1, 6.2, 7, 8, 9, 10, 11, 12)
    End If

    MM = 1
    While DaysInYear >= accMnthlen(MM)
        MM = MM + 1
    Wend

    DD = DaysInYear - accMnthlen(MM - 1) + 1

    CurMnthLen = accMnthlen(MM) - accMnthlen(MM - 1)
    If MM = 1 Then
        PrevMnthLen = 29
    Else
        PrevMnthLen = accMnthlen(MM - 1) - accMnthlen(MM - 2)
    End If

    strTemp = Replace(strTemp, "YYYY", QGymDesc(YY))
    strTemp = Replace(strTemp, "YYY", GymDesc(YY))
    strTemp = Replace(strTemp, "YY", YY)
    strTemp = Replace(strTemp, "Y", YY Mod 1000)

    strTemp = Replace(strTemp, "MM", MnthNames(MM))
    strTemp = Replace(strTemp, "M", MnthNum(MM))

    strTemp = Replace(strTemp, "DDD", QGymDesc(DD))
    strTemp = Replace(strTemp, "DD", GymDesc(DD))
    strTemp = Replace(strTemp, "D", DD)

    GregToHeb = strTemp

End Function

Private Function MoladRH(JYear As Long) As Variant
'הפונקציה מחשבת את תאריך ושעת המולד של ראש השנה עבור שנה עברית נתונה
'הפונקציה מקבלת כפרמטר מספר של שנה עברית (כולל אלפים) ומחזירה תאריך+שעה
    Dim Jmnth As Double
    Dim accGOHADZT
    Dim AccMnths As Long
    Dim Epoch As Double

    'מולד תוהו - השעות לפי 0 = 18:00
    Epoch = -2067021.0337963

    'אורך חודש - כ"ט י"ב תשצ"ג
    Jmnth = 29 + (12 + 793 / 1080) / 24

    'מערך צבירת חודשים מתחילת המחזור עד תחילת השנה
    accGOHADZT = Array(-13, 0, 12, 24, 37, 49, 61, 74, 86, 99, 111, 123, 136, 148, 160, 173, 185, 197, 210)

    'סה"כ חודשים ממולד תוהו
    AccMnths = Int(JYear / 19) * 235 + accGOHADZT(JYear Mod 19)

    'תאריך ושעת מולד ראש השנה
    MoladRH = AccMnths * Jmnth + Epoch
End Function

Private Function JRH(JYear As Long) As Date
'הפונקציה מחשבת את התאריך הגרגוריאני של ראש השנה עבור שנה עברית נתונה
'הפונקציה מקבלת כפרמטר מספר שנה עברית (כולל אלפים) ומחזירה תאריך גרגוריאני
    Dim Res As Date
    Dim DD As Integer
    Dim GOHADZT
    Dim HH As Double

    'מערך שנים רגילות ומעוברות - גו"ח אדז"ט
    GOHADZT = Array(13, 12, 12, 13, 12, 12, 13, 12, 13, 12, 12, 13, 12, 12, 13, 12, 12, 13, 12)

    'זמן מולד ראש השנה + 6 שעות כדי לעבור ליממה שבה 0 = חצות
    Res = MoladRH(JYear) + 0.25

    'HH - חלק היממה: שעת המולד בשבר עשרוני של ימים
    HH = Res - Int(Res)

    'ארבע הדחיות
    'מולד זקן
    If HH >= 18 / 24 Then
        Res = Res + 1
    End If

    'לא אד"ו ראש
    DD = Weekday(Res)
    If DD = 1 Or DD = 4 Or DD = 6 Then
        Res = Res + 1
    End If

    'ג"ט ר"ד בשנה פשוטה
    If GOHADZT(JYear Mod 19) = 12 And Weekday(Res) = 3 And HH >= (9 + 204 / 1080) / 24 And HH < 18 / 24 Then
        Res = Res + 2
    End If

    'בט"ו תקפ"ט אחרי עיבור
    If GOHADZT((JYear - 1) Mod 19) = 13 And Weekday(Res) = 2 And HH >= (15 + 589 / 1080) / 24 And HH < 18 / 24 Then
        Res = Res + 1
    End If

    'תאריך ראש השנה
    JRH = Int(Res)
End Function

Private Function GymDesc(X As Variant) As String
'הפונקציה מחשבת את הביטוי הגימטריוני (באותיות עבריות) של מספר בין אפס לאלף
    Dim Res As String
    Dim HH, DD, OO
    Dim R As Integer

    HH = Array("", "ק", "ר", "ש", "ת", "תק", "תר", "תש", "תת", "תתק")
    DD = Array("", "י", "כ", "ל", "מ", "נ", "ס", "ע", "פ", "צ")
    OO = Array("", "א", "ב", "ג", "ד", "ה", "ו", "ז", "ח", "ט")

    Select Case (X Mod 100)
        Case 15
            Res = HH(Int((X Mod 1000) / 100)) & "טו"
        Case 16
            Res = HH(Int((X Mod 1000) / 100)) & "טז"
        Case Else
            Res = OO(X Mod 10)
            R = Int((X Mod 1000) / 10)
            Res = HH(Int(R / 10)) & DD(R Mod 10) & Res
    End Select

    GymDesc = Res
End Function

Private Function QGymDesc(X As Variant) As String
    Dim Res As String
    Dim LL As Integer

    Res = GymDesc(X)
    LL = Len(Res)

    If LL = 1 Then
        Res = Res & "'"
    Else
        Res = Left(Res, LL - 1) & """" & Right(Res, 1)
    End If

    QGymDesc = Res
End Function

 

[ayg]

קובץ מצורף

נפלא!
לתועלות אלו שמתקשים בהכנסת המקרו, צרפתי כאן קובץ .dot
1) יש בו בין המקרו שלי, ובין של moishy
2) הוספתי בו גם אפשרות לקבל תאריך עברי לכל תאריך לעזי בתוך חלון קטן
3) אפשר להוסיף הקובץ לשביל התחלה כדי שיפתח מעצמו בכל התחלה [ראה בתוך הקבוץ דרך להגיע להשביל הנכון. וכן רשמתי שם עוד קיצורי דרך]

וכעת שאלה לר' moishy:
1) הרבה פעמים אינו מבחין בתאריך, אמאי?
2) כל החשבנות של הלוח נעשו בתוך המאקרו - האם אפשר לסומך על זה שהוא בדיוק? זה נבדוק? [במאקרו שהעילתי התאריכים נקחו מלוח הקיים]
3) מה יהא כשרוצים להפוך, שעל תאריך עברי יקבלו תאריך הלעזי [אולי תוסיף אפשרות כזה להקובץ המצורף]

 

[moishy]

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

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

בע"ה בעת הצגת הפתרון אוסיף גם המרה מעברי ללועזי.

 

[moishy]

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

Option Explicit

Sub FinalRegexTest()

    Dim oMatches As Object
    Dim iMatch As Integer
    Dim oMatch As Object
    Dim strTemp As String
    Dim RegExp As Object
    Set RegExp = CreateObject("VBScript.RegExp")

    If ActiveDocument.Tables.Count > 0 Then
        MsgBox "àðå îöèòøéí ìà ðéúï ìäôòéì úëåðä æå áîñîê ùéù áå èáìàåú."
        Exit Sub
    End If

    With RegExp
        .Global = True
        .Pattern = "\d{1,2}[\./-]\d{1,2}[\./-]\d{2,4}"
        .MultiLine = False
        Set oMatches = .Execute(ActiveDocument.Range.Text)

        For iMatch = oMatches.Count To 1 Step -1
            Set oMatch = oMatches(iMatch - 1)
            strTemp = Replace(oMatch, ".", "-")
            If IsDate(strTemp) Then
                ActiveDocument.Range(oMatch.FirstIndex, oMatch.FirstIndex + oMatch.Length) = GregToHeb(CDate(strTemp)) & " (" & oMatch & ")"
            End If
            strTemp = ""
        Next
    End With

    Set oMatches = Nothing
    Set oMatch = Nothing
    Set RegExp = Nothing

End Sub

Public Function GregToHeb(GrDate As Date, Optional DateString As String = "DDD MM YYYY") As Variant
'äôåð÷öéä îçæéøä úàøéê òáøé ëáéèåé è÷ñèåàìé òáåø úàøéê âøâåøéàðé ðúåï
'äôåð÷öéä î÷áìú ëôøîèøéí úàøéê òáøé åáéèåé è÷ñèåàìé
'åîçæéøä áéèåé ùáå îöééðé äî÷åí îåçìôéí ò"é øëéáé äúàøéê äòáøé ëãì÷îï
'D - éåí áçåãù áñôøåú
'DD - éåí áçåãù áàåúéåú ììà âøùééí
'DDD - éåí áçåãù áàåúéåú ëåìì âøùééí
'M - çåãù áñôøåú: úùøé = 1, àãø = 6, àãø à = 6.1, àãø á = 6.2
'MM - ùí äçåãù áîéìéí
'Y - ùðä áñôøåú ììà àìôéí
'YY - ùðä áñôøåú ëåìì àìôéí
'YYY - ùðä áàåúéåú, ììà àìôéí, ììà âøùééí
'YYYY - ùðä áàåúéåú ëåìì âøùééí

'äôåð÷öéä àéðä øâéùä ìàåúéåú âãåìåú àå ÷èðåú
'îçøåæú áøéøú äîçãì äéà: "DDD MM YYY"

    Dim dtPreviousRoshHashanah As Date, dtNextRoshHashanah As Date
    Dim intYearLen As Integer, intDaysInYear As Integer
    Dim intDayNum As Integer, intCurrentMonthLength As Integer, intPreviousMonthLength As Integer
    Dim arrMonthLength, arrMonthNames, arrMonthNumbers, arrWeekdayNames
    Dim strTemp As String
    Dim lngMonth, lngDay, lngYear As Long

    arrWeekdayNames = Array("ùáú", "øàùåï", "ùðé", "ùìéùé", "øáéòé", "çîéùé", "ùùé", "ùáú")
    intDayNum = Weekday(GrDate)

    strTemp = UCase(DateString)

    lngYear = Year(GrDate) + 3761
    dtPreviousRoshHashanah = fRoshHashanah(lngYear)
    If dtPreviousRoshHashanah <= GrDate Then
        dtNextRoshHashanah = fRoshHashanah(lngYear + 1)
    Else
        dtNextRoshHashanah = dtPreviousRoshHashanah
        lngYear = lngYear - 1
        dtPreviousRoshHashanah = fRoshHashanah(lngYear)
    End If

    intYearLen = dtNextRoshHashanah - dtPreviousRoshHashanah
    intDaysInYear = GrDate - dtPreviousRoshHashanah

    Select Case intYearLen
        Case 353
            arrMonthLength = Array(0, 30, 59, 88, 117, 147, 176, 206, 235, 265, 294, 324, 353)
        Case 354
            arrMonthLength = Array(0, 30, 59, 89, 118, 148, 177, 207, 236, 266, 295, 325, 354)
        Case 355
            arrMonthLength = Array(0, 30, 60, 90, 119, 149, 178, 208, 237, 267, 296, 326, 355)
        Case 383
            arrMonthLength = Array(0, 30, 59, 88, 117, 147, 177, 206, 236, 265, 295, 324, 354, 383)
        Case 384
            arrMonthLength = Array(0, 30, 59, 89, 118, 148, 178, 207, 237, 266, 296, 325, 355, 384)
        Case 385
            arrMonthLength = Array(0, 30, 60, 90, 119, 149, 179, 208, 238, 267, 297, 326, 356, 385)
    End Select

    If intYearLen < 380 Then
        arrMonthNames = Array("", "úùøé", "çùåï", "ëñìå", "èáú", "ùáè", "àãø", "ðéñï", "àééø", "ñéåï", "úîåæ", "àá", "àìåì")
        arrMonthNumbers = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
    Else
        arrMonthNames = Array("", "úùøé", "çùåï", "ëñìå", "èáú", "ùáè", "àãø à", "àãø á", "ðéñï", "àééø", "ñéåï", "úîåæ", "àá", "àìåì")
        arrMonthNumbers = Array(0, 1, 2, 3, 4, 5, 6.1, 6.2, 7, 8, 9, 10, 11, 12)
    End If

    lngMonth = 1
    While intDaysInYear >= arrMonthLength(lngMonth)
        lngMonth = lngMonth + 1
    Wend

    lngDay = intDaysInYear - arrMonthLength(lngMonth - 1) + 1

    intCurrentMonthLength = arrMonthLength(lngMonth) - arrMonthLength(lngMonth - 1)
    If lngMonth = 1 Then
        intPreviousMonthLength = 29
    Else
        intPreviousMonthLength = arrMonthLength(lngMonth - 1) - arrMonthLength(lngMonth - 2)
    End If

    strTemp = Replace(strTemp, "YYYY", fGimatria(lngYear, False, True, True))
    strTemp = Replace(strTemp, "YYY", fGimatria(lngYear, False, False))
    strTemp = Replace(strTemp, "YY", lngYear)
    strTemp = Replace(strTemp, "Y", lngYear Mod 1000)

    strTemp = Replace(strTemp, "MM", arrMonthNames(lngMonth))
    strTemp = Replace(strTemp, "M", arrMonthNumbers(lngMonth))

    strTemp = Replace(strTemp, "DDD", fGimatria(lngDay, False, True, True))
    strTemp = Replace(strTemp, "DD", fGimatria(lngDay, False, False, True))
    strTemp = Replace(strTemp, "D", lngDay)

    GregToHeb = strTemp

End Function

Public Function HebToGreg(lngHebYear As Long, dblHebMonth As Double, lngHebDay As Long) As Date
'äôåð÷öéä î÷áìú úàøéê òáøé îìà, åîçæéøä àú äúàøéê äìåòæé ùáå äåà çì
'äôåð÷öéä î÷áìú ùðä, çåãù, åéåí áìåç äòáøé, åîçæéøä úàøéê ìåòæé
'àí äçåãù äåà àãø à àå àãø á, áùðä ùàéðä îòåáøú - éåçæø úàøéê áàãø
'àí äçåãù äåà àãø ñúí áùðä îòåáøú - éåçæø úàøéê áàãø á
'àí äúàøéê äåà ì çùåï àå ì ëñìå áùðä ùáä àéï úàøéê ëæä - äúàøéê ééãçä áéåí
    Dim strTemp
    Dim ThisYearRoshHashanah, NextYearRoshHashanah
    Dim intYearLen As Integer
    Dim arrMonthLength
    Dim dblHebMonth As Double

    ThisYearRoshHashanah = fRoshHashanah(lngHebYear)
    NextYearRoshHashanah = fRoshHashanah(lngHebYear + 1)

    intYearLen = NextYearRoshHashanah - ThisYearRoshHashanah

    Select Case intYearLen
        Case 353
            arrMonthLength = Array(0, 30, 59, 88, 117, 147, 176, 206, 235, 265, 294, 324, 353)
        Case 354
            arrMonthLength = Array(0, 30, 59, 89, 118, 148, 177, 207, 236, 266, 295, 325, 354)
        Case 355
            arrMonthLength = Array(0, 30, 60, 90, 119, 149, 178, 208, 237, 267, 296, 326, 355)
        Case 383
            arrMonthLength = Array(0, 30, 59, 88, 117, 147, 177, 206, 236, 265, 295, 324, 354, 383)
        Case 384
            arrMonthLength = Array(0, 30, 59, 89, 118, 148, 178, 207, 237, 266, 296, 325, 355, 384)
        Case 385
            arrMonthLength = Array(0, 30, 60, 90, 119, 149, 179, 208, 238, 267, 297, 326, 356, 385)
    End Select

    If intYearLen < 380 Then
        dblHebMonth = Int(dblHebMonth)
    Else
        If dblHebMonth < 6.2 Then
            dblHebMonth = Int(dblHebMonth)
        Else
            dblHebMonth = Int(dblHebMonth) + 1
        End If
    End If

    strTemp = ThisYearRoshHashanah + arrMonthLength(dblHebMonth - 1) + lngHebDay - 1

    HebToGreg = strTemp

End Function

Private Function fRoshHashanahMolad(lngHebYear As Long) As Variant
'äôåð÷öéä îçùáú àú úàøéê åùòú äîåìã ùì øàù äùðä òáåø ùðä òáøéú ðúåðä
'äôåð÷öéä î÷áìú ëôøîèø îñôø ùì ùðä òáøéú (ëåìì àìôéí) åîçæéøä úàøéê+ùòä
    Dim dblMonthLength As Double
    Dim arrAccumaltiveMonthsPerYear
    Dim lngDistanceFromMoladTohu As Long
    Dim dblMoladTohu As Double

    'îåìã úåäå - äùòåú ìôé 0 = 18:00
    dblMoladTohu = -2067021.0337963

    'àåøê çåãù - ë"è é"á úùö"â
    dblMonthLength = 29 + (12 + 793 / 1080) / 24

    'îòøê öáéøú çåãùéí îúçéìú äîçæåø òã úçéìú äùðä
    arrAccumaltiveMonthsPerYear = Array(-13, 0, 12, 24, 37, 49, 61, 74, 86, 99, 111, 123, 136, 148, 160, 173, 185, 197, 210)

    'ñä"ë çåãùéí îîåìã úåäå
    lngDistanceFromMoladTohu = Int(lngHebYear / 19) * 235 + arrAccumaltiveMonthsPerYear(lngHebYear Mod 19)

    'úàøéê åùòú îåìã øàù äùðä
    fRoshHashanahMolad = lngDistanceFromMoladTohu * dblMonthLength + dblMoladTohu
End Function

Private Function fRoshHashanah(lngHebYear As Long) As Date
'äôåð÷öéä îçùáú àú äúàøéê äâøâåøéàðé ùì øàù äùðä òáåø ùðä òáøéú ðúåðä
'äôåð÷öéä î÷áìú ëôøîèø îñôø ùðä òáøéú (ëåìì àìôéí) åîçæéøä úàøéê âøâåøéàðé
    Dim strTemp As Date
    Dim intDayNumber As Integer
    Dim arrLengthOfYears As Variant
    Dim dblMoladTimeDecimal As Double

    'îòøê ùðéí øâéìåú åîòåáøåú - âå"ç àãæ"è
    arrLengthOfYears = Array(13, 12, 12, 13, 12, 12, 13, 12, 13, 12, 12, 13, 12, 12, 13, 12, 12, 13, 12)

    'æîï îåìã øàù äùðä + 6 ùòåú ëãé ìòáåø ìéîîä ùáä 0 = çöåú
    strTemp = fRoshHashanahMolad(lngHebYear) + 0.25

    'dblMoladTimeDecimal - çì÷ äéîîä: ùòú äîåìã áùáø òùøåðé ùì éîéí
    dblMoladTimeDecimal = strTemp - Int(strTemp)

    'àøáò äãçéåú
    'îåìã æ÷ï
    If dblMoladTimeDecimal >= 18 / 24 Then
        strTemp = strTemp + 1
    End If

    'ìà àã"å øàù
    intDayNumber = Weekday(strTemp)
    If intDayNumber = 1 Or intDayNumber = 4 Or intDayNumber = 6 Then
        strTemp = strTemp + 1
    End If

    'â"è ø"ã áùðä ôùåèä
    If arrLengthOfYears(lngHebYear Mod 19) = 12 And Weekday(strTemp) = 3 And dblMoladTimeDecimal >= (9 + 204 / 1080) / 24 And dblMoladTimeDecimal < 18 / 24 Then
        strTemp = strTemp + 2
    End If

    'áè"å ú÷ô"è àçøé òéáåø
    If arrLengthOfYears((lngHebYear - 1) Mod 19) = 13 And Weekday(strTemp) = 2 And dblMoladTimeDecimal >= (15 + 589 / 1080) / 24 And dblMoladTimeDecimal < 18 / 24 Then
        strTemp = strTemp + 1
    End If

    'úàøéê øàù äùðä
    fRoshHashanah = Int(strTemp)
End Function

'.äçæø àú äîñôø áàåôï âéîèøé áàåúéåú
'äôåð÷öéä ø÷åøñéáéú ëãé ìëìåì òøëéí äâãåìéí
'àå ùååéí ìàìó
'éù áå 4 àøâåîðèéí:
' 1. äîñôø äîáå÷ù
' 2. äàí ìëìåì àìôéí (ëâåï ä'úùò"â) (ëï/ìà) áøéøú äîçãì äéà ìà
' 3. äàí ìëìåì âøùééí (ëâåï úùò"â) (ëï/ìà) áøéøú äîçãì äéà ëï
' 4. äàí ìäùúîù áîñôøéí "ð÷ééí" (ëâåï òøä áî÷åí øòä) (ëï/ìà) áøéøú äîçãì äéà ëï

Private Function fGimatria(ByVal intNum As Integer, _
                           Optional blnIncludeThousands As Boolean = False, _
                           Optional blnIncludeQuotes 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
        strTemp = strTemp & Chr$(39)    ' äåñôú âøù àçø àåú äàìôéí
    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) >= 2 Then
            strTemp = Mid$(strTemp, 1, Len(strTemp) - 1) & Chr$(34) & Mid$(strTemp, Len(strTemp), 1)
        End If
    End If

    If Not blnIncludeThousands Then
        ' îåøéã àú äàåú äîñîì àú äàìôéí
        If InStr(strTemp, "'") Then
            If Len(strTemp) > 2 Then
                '        Debug.Print "before: " & strTemp
                strTemp = Right$(strTemp, Len(strTemp) - 2)
                '        Debug.Print "after: " & strTemp
            End If
        End If
    End If

    ' îçæéø àú äúåöàä äñåôéú
    fGimatria = strTemp

End Function

 

[FullTime]

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

מה פי' קובץ שיש בו טבלאות? .
באקסס הוא יעבוד?
ניסיתי והוא מבקש 2-3 ארגמנטים ואני לא יודע מה להכניס.

 

[moishy]

סליחה על השיבוש בעברית, הנה הקוד ללא הג'יבריש:

Option Explicit

Sub FinalRegexTest()

    Dim oMatches As Object
    Dim iMatch As Integer
    Dim oMatch As Object
    Dim strTemp As String
    Dim RegExp As Object
    Set RegExp = CreateObject("VBScript.RegExp")

    If ActiveDocument.Tables.Count > 0 Then
        MsgBox "אנו מצטערים לא ניתן להפעיל תכונה זו במסמך שיש בו טבלאות."
        Exit Sub
    End If

    With RegExp
        .Global = True
        .Pattern = "\d{1,2}[\./-]\d{1,2}[\./-]\d{2,4}"
        .MultiLine = False
        Set oMatches = .Execute(ActiveDocument.Range.Text)

        For iMatch = oMatches.Count To 1 Step -1
            Set oMatch = oMatches(iMatch - 1)
            strTemp = Replace(oMatch, ".", "-")
            If IsDate(strTemp) Then
                ActiveDocument.Range(oMatch.FirstIndex, oMatch.FirstIndex + oMatch.Length) = GregToHeb(CDate(strTemp)) & " (" & oMatch & ")"
            End If
            strTemp = ""
        Next
    End With

    Set oMatches = Nothing
    Set oMatch = Nothing
    Set RegExp = Nothing

End Sub

Public Function GregToHeb(nGregDate As Date, Optional strFormat As String = "DDD MM YYYY") As Variant
'הפונקציה מחזירה תאריך עברי כביטוי טקסטואלי עבור תאריך גרגוריאני נתון
'הפונקציה מקבלת כפרמטרים תאריך עברי וביטוי טקסטואלי
'ומחזירה ביטוי שבו מצייני המקום מוחלפים ע"י רכיבי התאריך העברי כדלקמן
'D - יום בחודש בספרות
'DD - יום בחודש באותיות ללא גרשיים
'DDD - יום בחודש באותיות כולל גרשיים
'M - חודש בספרות: תשרי = 1, אדר = 6, אדר א = 6.1, אדר ב = 6.2
'MM - שם החודש במילים
'Y - שנה בספרות ללא אלפים
'YY - שנה בספרות כולל אלפים
'YYY - שנה באותיות, ללא אלפים, ללא גרשיים
'YYYY - שנה באותיות כולל גרשיים

'הפונקציה אינה רגישה לאותיות גדולות או קטנות
'מחרוזת ברירת המחדל היא: "DDD MM YYY"

    Dim dtPreviousRoshHashanah As Date, dtNextRoshHashanah As Date
    Dim intYearLen As Integer, intDaysInYear As Integer
    Dim intDayNum As Integer, intCurrentMonthLength As Integer, intPreviousMonthLength As Integer
    Dim arrMonthLength, arrMonthNames, arrMonthNumbers, arrWeekdayNames
    Dim strTemp As String
    Dim lngMonth, lngDay, lngYear As Long

    arrWeekdayNames = Array("שבת", "ראשון", "שני", "שלישי", "רביעי", "חמישי", "ששי", "שבת")
    intDayNum = Weekday(nGregDate)

    strTemp = UCase(strFormat)

    lngYear = Year(nGregDate) + 3761
    dtPreviousRoshHashanah = fRoshHashanah(lngYear)
    If dtPreviousRoshHashanah <= nGregDate Then
        dtNextRoshHashanah = fRoshHashanah(lngYear + 1)
    Else
        dtNextRoshHashanah = dtPreviousRoshHashanah
        lngYear = lngYear - 1
        dtPreviousRoshHashanah = fRoshHashanah(lngYear)
    End If

    intYearLen = dtNextRoshHashanah - dtPreviousRoshHashanah
    intDaysInYear = nGregDate - dtPreviousRoshHashanah

    Select Case intYearLen
        Case 353
            arrMonthLength = Array(0, 30, 59, 88, 117, 147, 176, 206, 235, 265, 294, 324, 353)
        Case 354
            arrMonthLength = Array(0, 30, 59, 89, 118, 148, 177, 207, 236, 266, 295, 325, 354)
        Case 355
            arrMonthLength = Array(0, 30, 60, 90, 119, 149, 178, 208, 237, 267, 296, 326, 355)
        Case 383
            arrMonthLength = Array(0, 30, 59, 88, 117, 147, 177, 206, 236, 265, 295, 324, 354, 383)
        Case 384
            arrMonthLength = Array(0, 30, 59, 89, 118, 148, 178, 207, 237, 266, 296, 325, 355, 384)
        Case 385
            arrMonthLength = Array(0, 30, 60, 90, 119, 149, 179, 208, 238, 267, 297, 326, 356, 385)
    End Select

    If intYearLen < 380 Then
        arrMonthNames = Array("", "תשרי", "חשון", "כסלו", "טבת", "שבט", "אדר", "ניסן", "אייר", "סיון", "תמוז", "אב", "אלול")
        arrMonthNumbers = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
    Else
        arrMonthNames = Array("", "תשרי", "חשון", "כסלו", "טבת", "שבט", "אדר א", "אדר ב", "ניסן", "אייר", "סיון", "תמוז", "אב", "אלול")
        arrMonthNumbers = Array(0, 1, 2, 3, 4, 5, 6.1, 6.2, 7, 8, 9, 10, 11, 12)
    End If

    lngMonth = 1
    While intDaysInYear >= arrMonthLength(lngMonth)
        lngMonth = lngMonth + 1
    Wend

    lngDay = intDaysInYear - arrMonthLength(lngMonth - 1) + 1

    intCurrentMonthLength = arrMonthLength(lngMonth) - arrMonthLength(lngMonth - 1)
    If lngMonth = 1 Then
        intPreviousMonthLength = 29
    Else
        intPreviousMonthLength = arrMonthLength(lngMonth - 1) - arrMonthLength(lngMonth - 2)
    End If

    strTemp = Replace(strTemp, "YYYY", fGimatria(lngYear, False, True, True))
    strTemp = Replace(strTemp, "YYY", fGimatria(lngYear, False, False))
    strTemp = Replace(strTemp, "YY", lngYear)
    strTemp = Replace(strTemp, "Y", lngYear Mod 1000)

    strTemp = Replace(strTemp, "MM", arrMonthNames(lngMonth))
    strTemp = Replace(strTemp, "M", arrMonthNumbers(lngMonth))

    strTemp = Replace(strTemp, "DDD", fGimatria(lngDay, False, True, True))
    strTemp = Replace(strTemp, "DD", fGimatria(lngDay, False, False, True))
    strTemp = Replace(strTemp, "D", lngDay)

    GregToHeb = strTemp

End Function

Public Function HebToGreg(nHebYear As Long, nHebMonth As Double, nHebDay As Long) As Date
'הפונקציה מקבלת תאריך עברי מלא, ומחזירה את התאריך הלועזי שבו הוא חל
'הפונקציה מקבלת שנה, חודש, ויום בלוח העברי, ומחזירה תאריך לועזי
'אם החודש הוא אדר א או אדר ב, בשנה שאינה מעוברת - יוחזר תאריך באדר
'אם החודש הוא אדר סתם בשנה מעוברת - יוחזר תאריך באדר ב
'אם התאריך הוא ל חשון או ל כסלו בשנה שבה אין תאריך כזה - התאריך יידחה ביום
    Dim strTemp
    Dim ThisYearRoshHashanah, NextYearRoshHashanah
    Dim intYearLen As Integer
    Dim arrMonthLength

    ThisYearRoshHashanah = fRoshHashanah(nHebYear)
    NextYearRoshHashanah = fRoshHashanah(nHebYear + 1)

    intYearLen = NextYearRoshHashanah - ThisYearRoshHashanah

    Select Case intYearLen
        Case 353
            arrMonthLength = Array(0, 30, 59, 88, 117, 147, 176, 206, 235, 265, 294, 324, 353)
        Case 354
            arrMonthLength = Array(0, 30, 59, 89, 118, 148, 177, 207, 236, 266, 295, 325, 354)
        Case 355
            arrMonthLength = Array(0, 30, 60, 90, 119, 149, 178, 208, 237, 267, 296, 326, 355)
        Case 383
            arrMonthLength = Array(0, 30, 59, 88, 117, 147, 177, 206, 236, 265, 295, 324, 354, 383)
        Case 384
            arrMonthLength = Array(0, 30, 59, 89, 118, 148, 178, 207, 237, 266, 296, 325, 355, 384)
        Case 385
            arrMonthLength = Array(0, 30, 60, 90, 119, 149, 179, 208, 238, 267, 297, 326, 356, 385)
    End Select

    If intYearLen < 380 Then
        nHebMonth = Int(nHebMonth)
    Else
        If nHebMonth < 6.2 Then
            nHebMonth = Int(nHebMonth)
        Else
            nHebMonth = Int(nHebMonth) + 1
        End If
    End If

    strTemp = ThisYearRoshHashanah + arrMonthLength(nHebMonth - 1) + nHebDay - 1

    HebToGreg = strTemp

End Function

 Function fRoshHashanahMolad(lngHebYear As Long) As Variant
'הפונקציה מחשבת את תאריך ושעת המולד של ראש השנה עבור שנה עברית נתונה
'הפונקציה מקבלת כפרמטר מספר של שנה עברית (כולל אלפים) ומחזירה תאריך+שעה
    Dim dblMonthLength As Double
    Dim arrAccumaltiveMonthsPerYear
    Dim lngDistanceFromMoladTohu As Long
    Dim dblMoladTohu As Double

    'מולד תוהו - השעות לפי 0 = 18:00
    dblMoladTohu = -2067021.0337963

    'אורך חודש - כ"ט י"ב תשצ"ג
    dblMonthLength = 29 + (12 + 793 / 1080) / 24

    'מערך צבירת חודשים מתחילת המחזור עד תחילת השנה
    arrAccumaltiveMonthsPerYear = Array(-13, 0, 12, 24, 37, 49, 61, 74, 86, 99, 111, 123, 136, 148, 160, 173, 185, 197, 210)

    'סה"כ חודשים ממולד תוהו
    lngDistanceFromMoladTohu = Int(lngHebYear / 19) * 235 + arrAccumaltiveMonthsPerYear(lngHebYear Mod 19)

    'תאריך ושעת מולד ראש השנה
    fRoshHashanahMolad = lngDistanceFromMoladTohu * dblMonthLength + dblMoladTohu
End Function

 Function fRoshHashanah(lngHebYear As Long) As Date
'הפונקציה מחשבת את התאריך הגרגוריאני של ראש השנה עבור שנה עברית נתונה
'הפונקציה מקבלת כפרמטר מספר שנה עברית (כולל אלפים) ומחזירה תאריך גרגוריאני
    Dim strTemp As Date
    Dim intDayNumber As Integer
    Dim arrLengthOfYears As Variant
    Dim dblMoladTimeDecimal As Double

    'מערך שנים רגילות ומעוברות - גו"ח אדז"ט
    arrLengthOfYears = Array(13, 12, 12, 13, 12, 12, 13, 12, 13, 12, 12, 13, 12, 12, 13, 12, 12, 13, 12)

    'זמן מולד ראש השנה + 6 שעות כדי לעבור ליממה שבה 0 = חצות
    strTemp = fRoshHashanahMolad(lngHebYear) + 0.25

    'dblMoladTimeDecimal - חלק היממה: שעת המולד בשבר עשרוני של ימים
    dblMoladTimeDecimal = strTemp - Int(strTemp)

    'ארבע הדחיות
    'מולד זקן
    If dblMoladTimeDecimal >= 18 / 24 Then
        strTemp = strTemp + 1
    End If

    'לא אד"ו ראש
    intDayNumber = Weekday(strTemp)
    If intDayNumber = 1 Or intDayNumber = 4 Or intDayNumber = 6 Then
        strTemp = strTemp + 1
    End If

    'ג"ט ר"ד בשנה פשוטה
    If arrLengthOfYears(lngHebYear Mod 19) = 12 And Weekday(strTemp) = 3 And dblMoladTimeDecimal >= (9 + 204 / 1080) / 24 And dblMoladTimeDecimal < 18 / 24 Then
        strTemp = strTemp + 2
    End If

    'בט"ו תקפ"ט אחרי עיבור
    If arrLengthOfYears((lngHebYear - 1) Mod 19) = 13 And Weekday(strTemp) = 2 And dblMoladTimeDecimal >= (15 + 589 / 1080) / 24 And dblMoladTimeDecimal < 18 / 24 Then
        strTemp = strTemp + 1
    End If

    'תאריך ראש השנה
    fRoshHashanah = Int(strTemp)
End Function

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

Public Function fGimatria(ByVal intNum As Integer, _
                           Optional blnIncludeThousands As Boolean = False, _
                           Optional blnIncludeQuotes 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
        strTemp = strTemp & Chr$(39)    ' הוספת גרש אחר אות האלפים
    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) >= 2 Then
            strTemp = Mid$(strTemp, 1, Len(strTemp) - 1) & Chr$(34) & Mid$(strTemp, Len(strTemp), 1)
        End If
    End If

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

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

End Function

 

[moishy]

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

הקודים להמרת עברי/לועזי ולהיפך עובדים גם באקסס.

להמרת עברי ללועזי יש לפסק לו את הארגומנטים הבאים:
שנה עברי במספר (לדוגמא 5773)
חודש עברי במספר (לדוגמא 10)
יום עברי במספר (לדוגמא 27)

להמרת לועזי לעברי יש לפסק לו את הרגומנט הבא:
תאריך לועזי בתאריך (לדוגמא Now(), או CDate("05/07/20013") .
יש עוד ארגומנט אופציונלי, ראה את הקוד בתחילת הפונקציה GregToHeb לפרטים.

 

[FullTime]

תודה רבה לך מוישי

יש 2 שגיאות בקוד החדש ב2 השורות האלו.

Public Function GregToHeb(GrDate As Date, Optional DateString As String = "DDD MM YYYY") As Variant

  If dtPreviousRoshHashanah <= GrDate Then

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

 

[vn453]

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

שלום מוישי ו- ayg
המאקרו של מוישי עבד אצלי עכשיו (לאחר העדכון שעשה לו) ותשואות חן חן לשניכם.
אציין כמה נקודות שאם תרצו לעיין בהן ולתקנן – יהיה המאקרו מושלם בתכלית:
1. התאריך בימים א–י לחודש מופיע ללא גרש מעל האות.
2. בטקסט ארוך מופיעים תאריכים בכמה צורות למשל:
2/7/2013
2.7.2013
02/7/2013
2.07.13
המאקרו של מוישי הופך זאת כך:
כ"ד תמוז תשע"ג (2/7/2013)
כ"ד תמוז תשע"ג (2.7.2013)
כ"ד תמוז תשע"ג (02/7/2013)
כ"ד תמוז תשע"ג (2.07.13)
כלומר הוא משאיר כל מופע תאריך לועזי כפי שהיה במקור ללא שינוי.
אבל צריך לאחד את כל מופעי התאריכים ולתת להם מבנה זהה, כך (2/7/2013) או (2.7.2013). כלומר ללא הספרה 0 בימים ובחודשים אבל עם שנות האלפים בשנים. האם הדבר אפשרי במאקרו של מוישי? ראיתי ש-ayg הצליח לעשות זאת במאקרו שהציע.
כמו כן, בתחילה העדפתי את המופע הסופי כך: (2.7.2013) אבל במחשבה שנייה אולי עדיף לעשות עם לוכסנים כך: (2/7/2013) כי אם איני טועה האקסל מזהה תאריכים רק אם יש בהם לוכסנים. מה דעתכם?
3. בלשון הקודש תמיד צריכה לבוא האות ב' לפני שם החודש, כמו "ט' באב". האם אפשר לתת פקודה במאקרו שתמיד לפני שם החודש תופיע האות ב'? כך: "י"ז בתמוז תשע"ג", ולא: "י"ז תמוז תשע"ג". על דרך זו, האם אפשר שיירשם "אדר א'" וכן "אדר ב'" ולא "אדר א" ולא "אדר ב"?
4. במסמך שאני עובד עליו יש כמה תאריכים הכתובים באופן כמעט תקין. למשל היה כתוב מראש:
כ"א בטבת התשע"ב (16/01/2012)
המאקרו הופך זאת כך:
כ"א בטבת התשע"ב (כ"א טבת תשע"ב (16/01/2012))
האם אפשר שהמאקרו יזהה שכבר יש תאריך, יתקנו לצורה הנכונה, וימחק את ההכפלה של התאריך העברי, כך:
כ"א בטבת תשע"ב (16/1/2012) [השמטת ה' לפני השנה והשמטת 0 לפני ספרת החודש]
אני חוזר ומודה לכם על טרחתכם הרבה ונכונותכם לעזור.

 

[moishy]

הקוד המצורף נותן מענה לנקודות 1-3. לגבי הנקודה הרביעית אין לי זמן וכח, אולי אי מי מהחברים כאן יתנדב. בכל מקרה קשה להאמין שעשיתה בצורה ידנית טומנת בחובה יותר עבודה מהתיכנות...

הערה: הקוד כאן הוא במענה לשאלה המקורית של פותח האשכול, מי שמעוניין בפתרון כללי להמרת תאריכים, עברי/לועזי לועזי/עברי יועיל בטובו לעיין כאן.

Option Explicit

Sub FinalRegexTest()

    Dim oMatches As Object
    Dim iMatch As Integer
    Dim oMatch As Object
    Dim strTemp As String
    Dim RegExp As Object
    Set RegExp = CreateObject("VBScript.RegExp")
    Dim strFormat As String
    
    strFormat = "DD/MM/YYYY"  ' כאן ניתן לשנות את הפורמט של התאריכים הלועזיים

    With RegExp
        .Global = True
        .Pattern = "\d{1,2}[\./-]\d{1,2}[\./-]\d{2,4}"
        .MultiLine = False
        Set oMatches = .Execute(ActiveDocument.Range.text)

        For iMatch = oMatches.Count To 1 Step -1
            Set oMatch = oMatches(iMatch - 1)
            'Debug.Print "oMatch: " & oMatch
            strTemp = Replace(oMatch, ".", "-")
            'Debug.Print "strTemp: " & strTemp
            If IsDate(strTemp) Then
                ActiveDocument.Range(oMatch.FirstIndex, oMatch.FirstIndex + oMatch.Length) = Format(oMatch, strFormat)
                ActiveDocument.Range(oMatch.FirstIndex, oMatch.FirstIndex + oMatch.Length) = GregToHeb(CDate(strTemp)) & " (" & Format(oMatch, strFormat) & ")"
            End If
            strTemp = ""
        Next
    End With

    Set oMatches = Nothing
    Set oMatch = Nothing
    Set RegExp = Nothing

End Sub

Public Function GregToHeb(nGregDate As Date, Optional strFormat As String = "DDD MM YYYY") As Variant
'הפונקציה מחזירה תאריך עברי כביטוי טקסטואלי עבור תאריך גרגוריאני נתון
'הפונקציה מקבלת כפרמטרים תאריך עברי וביטוי טקסטואלי
'ומחזירה ביטוי שבו מצייני המקום מוחלפים ע"י רכיבי התאריך העברי כדלקמן
'D - יום בחודש בספרות
'DD - יום בחודש באותיות ללא גרשיים
'DDD - יום בחודש באותיות כולל גרשיים
'M - חודש בספרות: תשרי = 1, אדר = 6, אדר א = 6.1, אדר ב = 6.2
'MM - שם החודש במילים
'Y - שנה בספרות ללא אלפים
'YY - שנה בספרות כולל אלפים
'YYY - שנה באותיות, ללא אלפים, ללא גרשיים
'YYYY - שנה באותיות כולל גרשיים

'הפונקציה אינה רגישה לאותיות גדולות או קטנות
'מחרוזת ברירת המחדל היא: "DDD MM YYY"

    Dim dtPreviousRoshHashanah As Date, dtNextRoshHashanah As Date
    Dim intYearLen As Integer, intDaysInYear As Integer
    Dim intDayNum As Integer, intCurrentMonthLength As Integer, intPreviousMonthLength As Integer
    Dim arrMonthLength, arrMonthNames, arrMonthNumbers, arrWeekdayNames
    Dim strTemp As String
    Dim lngMonth, lngDay, lngYear As Long

    arrWeekdayNames = Array("שבת", "ראשון", "שני", "שלישי", "רביעי", "חמישי", "ששי", "שבת")
    intDayNum = Weekday(nGregDate)

    strTemp = UCase(strFormat)

    lngYear = Year(nGregDate) + 3761
    dtPreviousRoshHashanah = fRoshHashanah(lngYear)
    If dtPreviousRoshHashanah <= nGregDate Then
        dtNextRoshHashanah = fRoshHashanah(lngYear + 1)
    Else
        dtNextRoshHashanah = dtPreviousRoshHashanah
        lngYear = lngYear - 1
        dtPreviousRoshHashanah = fRoshHashanah(lngYear)
    End If

    intYearLen = dtNextRoshHashanah - dtPreviousRoshHashanah
    intDaysInYear = nGregDate - dtPreviousRoshHashanah

    Select Case intYearLen
        Case 353
            arrMonthLength = Array(0, 30, 59, 88, 117, 147, 176, 206, 235, 265, 294, 324, 353)
        Case 354
            arrMonthLength = Array(0, 30, 59, 89, 118, 148, 177, 207, 236, 266, 295, 325, 354)
        Case 355
            arrMonthLength = Array(0, 30, 60, 90, 119, 149, 178, 208, 237, 267, 296, 326, 355)
        Case 383
            arrMonthLength = Array(0, 30, 59, 88, 117, 147, 177, 206, 236, 265, 295, 324, 354, 383)
        Case 384
            arrMonthLength = Array(0, 30, 59, 89, 118, 148, 178, 207, 237, 266, 296, 325, 355, 384)
        Case 385
            arrMonthLength = Array(0, 30, 60, 90, 119, 149, 179, 208, 238, 267, 297, 326, 356, 385)
    End Select

    If intYearLen < 380 Then
        arrMonthNames = Array("", "בתשרי", "בחשון", "בכסלו", "בטבת", "בשבט", "באדר", "בניסן", "באייר", "בסיון", "בתמוז", "באב", "באלול")
        arrMonthNumbers = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
    Else
        arrMonthNames = Array("", "בתשרי", "בחשון", "בכסלו", "בטבת", "בשבט", "באדר א", "באדר ב", "בניסן", "באייר", "בסיון", "בתמוז", "באב", "באלול")
        arrMonthNumbers = Array(0, 1, 2, 3, 4, 5, 6.1, 6.2, 7, 8, 9, 10, 11, 12)
    End If

    lngMonth = 1
    While intDaysInYear >= arrMonthLength(lngMonth)
        lngMonth = lngMonth + 1
    Wend

    lngDay = intDaysInYear - arrMonthLength(lngMonth - 1) + 1

    intCurrentMonthLength = arrMonthLength(lngMonth) - arrMonthLength(lngMonth - 1)
    If lngMonth = 1 Then
        intPreviousMonthLength = 29
    Else
        intPreviousMonthLength = arrMonthLength(lngMonth - 1) - arrMonthLength(lngMonth - 2)
    End If

    strTemp = Replace(strTemp, "YYYY", fGimatria(lngYear, False, True, True))
    strTemp = Replace(strTemp, "YYY", fGimatria(lngYear, False, False))
    strTemp = Replace(strTemp, "YY", lngYear)
    strTemp = Replace(strTemp, "Y", lngYear Mod 1000)

    strTemp = Replace(strTemp, "MM", arrMonthNames(lngMonth))
    strTemp = Replace(strTemp, "M", arrMonthNumbers(lngMonth))

    strTemp = Replace(strTemp, "DDD", fGimatria(lngDay, False, True, True))
    strTemp = Replace(strTemp, "DD", fGimatria(lngDay, False, False, True))
    strTemp = Replace(strTemp, "D", lngDay)

    GregToHeb = strTemp

End Function

Function fRoshHashanahMolad(lngHebYear As Long) As Variant
'הפונקציה מחשבת את תאריך ושעת המולד של ראש השנה עבור שנה עברית נתונה
'הפונקציה מקבלת כפרמטר מספר של שנה עברית (כולל אלפים) ומחזירה תאריך+שעה
    Dim dblMonthLength As Double
    Dim arrAccumaltiveMonthsPerYear
    Dim lngDistanceFromMoladTohu As Long
    Dim dblMoladTohu As Double

    'מולד תוהו - השעות לפי 0 = 18:00
    dblMoladTohu = -2067021.0337963

    'אורך חודש - כ"ט י"ב תשצ"ג
    dblMonthLength = 29 + (12 + 793 / 1080) / 24

    'מערך צבירת חודשים מתחילת המחזור עד תחילת השנה
    arrAccumaltiveMonthsPerYear = Array(-13, 0, 12, 24, 37, 49, 61, 74, 86, 99, 111, 123, 136, 148, 160, 173, 185, 197, 210)

    'סה"כ חודשים ממולד תוהו
    lngDistanceFromMoladTohu = Int(lngHebYear / 19) * 235 + arrAccumaltiveMonthsPerYear(lngHebYear Mod 19)

    'תאריך ושעת מולד ראש השנה
    fRoshHashanahMolad = lngDistanceFromMoladTohu * dblMonthLength + dblMoladTohu
End Function

Function fRoshHashanah(lngHebYear As Long) As Date
'הפונקציה מחשבת את התאריך הגרגוריאני של ראש השנה עבור שנה עברית נתונה
'הפונקציה מקבלת כפרמטר מספר שנה עברית (כולל אלפים) ומחזירה תאריך גרגוריאני
    Dim strTemp As Date
    Dim intDayNumber As Integer
    Dim arrLengthOfYears As Variant
    Dim dblMoladTimeDecimal As Double

    'מערך שנים רגילות ומעוברות - גו"ח אדז"ט
    arrLengthOfYears = Array(13, 12, 12, 13, 12, 12, 13, 12, 13, 12, 12, 13, 12, 12, 13, 12, 12, 13, 12)

    'זמן מולד ראש השנה + 6 שעות כדי לעבור ליממה שבה 0 = חצות
    strTemp = fRoshHashanahMolad(lngHebYear) + 0.25

    'dblMoladTimeDecimal - חלק היממה: שעת המולד בשבר עשרוני של ימים
    dblMoladTimeDecimal = strTemp - Int(strTemp)

    'ארבע הדחיות
    'מולד זקן
    If dblMoladTimeDecimal >= 18 / 24 Then
        strTemp = strTemp + 1
    End If

    'לא אד"ו ראש
    intDayNumber = Weekday(strTemp)
    If intDayNumber = 1 Or intDayNumber = 4 Or intDayNumber = 6 Then
        strTemp = strTemp + 1
    End If

    'ג"ט ר"ד בשנה פשוטה
    If arrLengthOfYears(lngHebYear Mod 19) = 12 And Weekday(strTemp) = 3 And dblMoladTimeDecimal >= (9 + 204 / 1080) / 24 And dblMoladTimeDecimal < 18 / 24 Then
        strTemp = strTemp + 2
    End If

    'בט"ו תקפ"ט אחרי עיבור
    If arrLengthOfYears((lngHebYear - 1) Mod 19) = 13 And Weekday(strTemp) = 2 And dblMoladTimeDecimal >= (15 + 589 / 1080) / 24 And dblMoladTimeDecimal < 18 / 24 Then
        strTemp = strTemp + 1
    End If

    'תאריך ראש השנה
    fRoshHashanah = Int(strTemp)
End Function

'.החזר את המספר באופן גימטרי באותיות
'הפונקציה רקורסיבית כדי לכלול ערכים הגדולים
'או שווים לאלף
'יש בו 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

 

[vn453]

תודה רבה על הטרחה הגדולה!

 

[kap]

הקפצה מהעבר.. איך אפשר שיחול גם על הערות שוליים וסיום?

 

[b1e2n3]

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