@pcinfogmach
אכן כמו ש @שלמה11 כתב האופציה הזאת לא עובדת
בסיום הפעולה הטורים שווים עד 0.1 נקודה שזה 0.035 מ"מ, נראה לך שצריך יותר???
כן. כפי שכבר ביארתי רבות אם נוסיף את הסטייה של היישור עמוד לסטייה של היישור טורים זה כבר מצטבר למשהו גדול.
ובנוסף לזה כפי שביארתי אין טעם לדייק ב 98% אם יש דרך פשוטה לדייק ב 100% (נראה לי שהדרך שהצעתי היא מאד מאד פשוטה) ובתור אחד שמבין בעימוד לדעתי זה גם חלק די קריטי.
עכ"פ בקשתי מ AI לעשות את זה וזה מה שהוא נתן (כמובן שזה לא עובד...)
Sub StretchColumnToBottom()
Dim doc As Document
Dim selectionRange As Range
Dim totalLines As Long
Dim footerLines As Long
Dim originalLineCount As Long
Dim currentLineCount As Long
Dim para As Paragraph
Dim spaceAfter As Single
Dim columnRange As Range
Dim i As Long
Dim endOfColumn As Boolean
Set doc = ActiveDocument
Set selectionRange = Selection.Range
Set columnRange = selectionRange.Duplicate
' שלב 1: ספירת השורות בטור אליו נמצא הסמן
totalLines = CountLinesInColumn(columnRange)
' שלב 2: ספירת שורות בהערות שוליים אם יש
footerLines = CountFootnotes(doc)
originalLineCount = totalLines + footerLines
currentLineCount = originalLineCount
' שלב 3: לולאת הגדלת הרווחים
Do While currentLineCount = originalLineCount
' שלב 4: סמן את כל הפיסקאות בטור, חוץ מהאחרונה
For Each para In columnRange.Paragraphs
If para.Index < columnRange.Paragraphs.Count Then
spaceAfter = para.Range.ParagraphFormat.SpaceAfter
para.Range.ParagraphFormat.SpaceAfter = spaceAfter + 0.05
End If
Next para
' שלב 6: בדוק אם יש שינוי במספר השורות
currentLineCount = CountLinesInColumn(columnRange) + footerLines
If currentLineCount <> originalLineCount Then
Exit Do
End If
Loop
' שלב 7: סוף לולאה ראשונה
' שלב 8: בחר את הפיסקה הראשונה בטור
Set para = columnRange.Paragraphs(1)
' שלב 9: לולאת הקטנת הרווחים
Do
' שלב 10: בחר את הפיסקה הבאה או את הראשונה אם הגעת לאחרונה
If para.Index < columnRange.Paragraphs.Count Then
Set para = columnRange.Paragraphs(para.Index + 1)
Else
Set para = columnRange.Paragraphs(1)
End If
' שלב 11: הורד 0.05 נקודות מהמרווח אחרי הפיסקה
spaceAfter = para.Range.ParagraphFormat.SpaceAfter
para.Range.ParagraphFormat.SpaceAfter = spaceAfter - 0.05
' שלב 12: בדוק אם מספר השורות השתנה
currentLineCount = CountLinesInColumn(columnRange) + footerLines
If currentLineCount = originalLineCount Then
Exit Do
End If
Loop
' שלב 13: סוף לולאה שנייה
End Sub
Function CountLinesInColumn(columnRange As Range) As Long
Dim para As Paragraph
Dim totalLines As Long
totalLines = 0
For Each para In columnRange.Paragraphs
totalLines = totalLines + para.Range.ComputeStatistics(wdStatisticLines)
Next para
CountLinesInColumn = totalLines
End Function
Function CountFootnotes(doc As Document) As Long
Dim footnote As Footnote
Dim totalLines As Long
totalLines = 0
For Each footnote In doc.Footnotes
totalLines = totalLines + footnote.Range.ComputeStatistics(wdStatisticLines)
Next footnote
CountFootnotes = totalLines
End Function