התאמת טקסט לטבלא

[לייזער]

אין סימן סוף פיסקא הבעי' כאן, מאחר ובסיום כל תא ישנו סימן, שעל אף שאינו עולה בחיפוש כסימון סוף פיסקא (כמבואר באשכול אח&#1512, אך מכל מקום נחשב הוא כסוף פיסקא, לענין חלוקת הפיסקאות ועוד.

שמא תעלה לכאן דוגמא קטנה?
כי בבדיקה שעשיתי אצלי לא נתקלתי בבעי' שתיארת.
ות"ח מראש.

 

[לייזער]

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

 

[לייזער]

השינוי הבא לקמן אמור לסדר את הבעי' הנזכרת.
כדאי להעתיק מכאן שוב את המאקרא כולו, כי ישנם כאן (בנוסף לשינוי העיקרי שנצבעה באדו&#1501 - גם מחיקות (של כמה פרטים ששוב לא הי' בהם צורך לאחר השינו&#1497, ואת המחיקות קשה להבליט ע"י צבע...

[LEFT]Sub ParaForceOneLine()
    Dim objPara As Paragraph, myRange As Range
    Const DefaultScale = 100, DefaultSize = 6.5
    Const MinScale = 85, MinSize = 6
    Const ChangeScale = 5, ChangeSize = 0.5
    
    If Len(Selection.Range) = 0 Then
        Set myRange = activedocument.Range(Start:=Selection.Range.Start, _
        End:=activedocument.Content.End)
    Else: Set myRange = Selection.Range: End If
    
    For Each objPara In myRange.Paragraphs
        With objPara.Range
            If Len(objPara.Range) <= 2 Or .Information(wdAtEndOfRowMarker) Then GoTo sNext
[COLOR="Red"]            If .Information(wdWithInTable) Then .MoveEnd unit:=wdCharacter, Count:=-1[/COLOR]
            While .Information(wdFirstCharacterLineNumber) <> _
                .Characters(Len(.Text)).Information(wdFirstCharacterLineNumber)
                If .Font.Scaling > DefaultScale Or .Font.SizeBi > DefaultSize Then
                    .Font.Scaling = DefaultScale: .Font.SizeBi = DefaultSize: GoTo sWend
                End If
                If .Font.Scaling >= (MinScale + ChangeScale) Then
                    .Font.Scaling = .Font.Scaling - ChangeScale
                ElseIf .Font.SizeBi >= (MinSize + ChangeSize) Then .Font.SizeBi = .Font.SizeBi - ChangeSize
                Else: objPara.Range.Select: MsgBox "&#1500;&#1488; &#1492;&#1510;&#1500;&#1497;&#1495; &#1500;&#1491;&#1495;&#1493;&#1505; &#1508;&#1497;&#1505;&#1511;&#1488; &#1494;&#1493; &#1500;&#1514;&#1493;&#1498; &#1513;&#1493;&#1512;&#1492; &#1488;&#1495;&#1514;": Exit Sub
                End If
sWend:
            Wend
        End With
sNext:
    Next objPara
End Sub[/LEFT]

ושוב, סליחה על אי ההבנה. ואני מקווה שעכ"פ עתה כן הבנתי.
באם עוד ישנם תקלות - נא להודיע.

 

[tkh]

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

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

 

[לייזער]

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

[LEFT]Sub ParaForceOneLine()
    Dim objPara As Paragraph, myRange As Range[COLOR="red"], i As Integer[/COLOR]
    Const DefaultScale = 100, DefaultSize = 6.5
    Const MinScale = 85, MinSize = 6
    Const ChangeScale = 5, ChangeSize = 0.5
    
    If Len(Selection.Range) = 0 Then
        Set myRange = ActiveDocument.Range(Start:=Selection.Range.Start, _
        End:=ActiveDocument.Content.End)
    Else: Set myRange = Selection.Range: End If
    
    For Each objPara In myRange.Paragraphs
        With objPara.Range
            If Len(objPara.Range) <= 2 Or .Information(wdAtEndOfRowMarker) Then GoTo sNext
            If .Information(wdWithInTable) Then .MoveEnd unit:=wdCharacter, Count:=-1
            While .Information(wdFirstCharacterLineNumber) <> _
                .Characters(Len(.Text)).Information(wdFirstCharacterLineNumber)
                If .Font.Scaling > DefaultScale Or .Font.SizeBi > DefaultSize Then
                    .Font.Scaling = DefaultScale: .Font.SizeBi = DefaultSize: GoTo sWend
                End If
                If .Font.Scaling >= (MinScale + ChangeScale) Then
                    .Font.Scaling = .Font.Scaling - ChangeScale
                ElseIf .Font.SizeBi >= (MinSize + ChangeSize) Then .Font.SizeBi = .Font.SizeBi - ChangeSize
                Else: objPara.Range.Select
[COLOR="red"]                    i = MsgBox("&#1500;&#1488; &#1492;&#1510;&#1500;&#1497;&#1495; &#1500;&#1491;&#1495;&#1493;&#1505; &#1508;&#1497;&#1505;&#1511;&#1488; &#1494;&#1493; &#1500;&#1514;&#1493;&#1498; &#1513;&#1493;&#1512;&#1492; &#1488;&#1495;&#1514;" & Chr(13) & "&#1500;&#1492;&#1502;&#1513;&#1497;&#1498;?", _
                        vbOKCancel + vbMsgBoxRight + vbMsgBoxRtlReading)
                    If i = 1 Then GoTo sNext Else Exit Sub[/COLOR]
                End If
sWend:
            Wend
        End With
sNext:
    Next objPara
End Sub[/LEFT]

באם יש לך הרבה שורות כאלו שלא יוכלו להתצמצם לתוך שורה אחת, ואינך רוצה להיות מוטרד כל הזמן ע"י ההודעה הצצה שלא הצליח וכו', אתה יכול גם להחליף (קרוב לסוף המאקר&#1488 את ג' השורות הצבועות בצבע אדום יחד עם השורה (בצבע שחו&#1512 שמעלי' לשורה דלקמן, וזה יצבע את אותה הפיסקא בצבע בולט (כגון כחו&#1500, מבלי להודיע שלא הצליח:

[LEFT]                Else: .Font.Color = wdColorBlue: GoTo sNext[/LEFT]

באם גם את זה אינך רוצה, אלא פשוט להמשיך (ולאחר מכן כבר תחפש בעצמך אלו שורות לא הצליח לדחו&#1505, אפשר לרשום (במקום ד' שורות הנ"ל (ג' שבצבע אדום והשורה שמעליה&#1501):

[LEFT]                Else: GoTo sNext[/LEFT]

אפשר גם להוסיף, שבמקרה שלא הצליח לדחוס לתוך שורה אחת - שיחזיר את ההצרה והגודל להגדרת ברירת מחדל כרשום בתחילת המאקרא. האם יש לך צורך בזה?
באם כן - תשלב את השורה הבאה בין התיבה "Else:" להבא אחריו - לפי כל ג' האופציות דלעיל:

[LEFT].Font.Scaling = DefaultScale: .Font.SizeBi = DefaultSize:[/LEFT]

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

 

[tkh]

נראה לי שצריך גם מלבד כפתור "שלח תודה", כפתור "תודה כפולה ומכופלת", על כאלו מאמצים ורצון לרדת לדעת השני בכל מה שאפשר.
כה לחי!
אכן קולע אל השערה ולא יחטיא. זה מה שאני צריך (עם האופצי' של לצבוע בכחו&#1500.

 

[צורת הדף]

לייזער,
ממש געוואלדיג

כה לחי!