שיתוף | יישור טורים מאקרו חדש!!!
-
בסייעתא דשמיא
עדכון המאקרו יישור טורים - תוספות ותיקונים
בהמשך להערות וההארות שנכתבו בשרשור זה בסייעתא דשמיא הנני להציע לציבור היקר את מאקרו יישור טורים גרסה 3
א.סודר ענין השגיאה של מרווח פחות מ0
וכמו כן נקבע שמרווח בין פסקאות לא יוכל לחרוג מטווח של 2.5 נקודות מינימום ו25 נקודת מקסימום (וזה לצורך הנראות הבסיסית) ונוסף גם שכשלא מצליח בטור הראשון (שהוא רב בפסקאות לעומת השני) מנסה בטור השני (ואם בשני טורים לא עומד בכללים אז ביישור מסמך שלם או מספר עמודים מדלג באופן אוטומטי לעמוד הבא וביישור עמוד אחד מודיע שלא עומד בכללים שהוצבו)
ב. כמו כן מדלג על מסגרות ותיבות טקסט
(ג. כמו כן מאחר שהוגדר מינימום 2.5 נקודות ממילא לא תהיה בעיה של עובי כתב בכותרת)
ד. נוסף פקודה יישור ממיקום הסמן עד סוף כל המסמך (וטוב במקרה של באג וכו לדלג על המקום הבעייתי)
ה. נוסף פקודה ליישור מכותרת על טור 1 עד כותרת הבאה (דהיינו סימן אחד בקונטרס)
ו. ביישור כל המסמך במקרה שיש כותרת באמצע עמוד מיישר גם את החלק העליון וגם את התחתון
בהצלחה
ואשמח לשמוע אם עובד כמצופה וכן על באגים שלא יהיו וכן הצעות ייעול
נראה שהוא דבר שיכול להועיל להרבה משתמשים ולחסוך זמן לכן אני מקווה לעשות כתוסף לכשיהיה מושלם
וכן בכוונתי להוסיף אפשרות להגדיר את הטווח מינימום ומקסימום ועוד בל"נ
הכל בעזרתו יתברך ובישועתו
מצ"ב הקובץיישור טורים 3.dotm ועודכן בפוסט הראשיוהקוד המתוקן והמשופץ
ליישור עמוד אחדDim WRange, Endcol2, Startcol1, Rcol1, Rcol2 As Range Dim NumLines, WPage, Pcol1, Pcol2, APcol, PPS, a, i, B, C, LM, P, S, V, col1, col2, Acol, Ignore As Double Public Sub יישור_טורים_עמוד_זה() 'בודק אם יש שני טורים If Selection.PageSetup.TextColumns.Count <> 2 Then MsgBox ("לא נמצאו 2 טורים"): Exit Sub 'עדכון מסך שקר Application.ScreenUpdating = False Dim WRange, Endcol2, Startcol1, Rcol1, Rcol2 As Range Dim NumLines, WPage, Pcol1, Pcol2, APcol, PPS, a, i, B, C, LM, P, S, V, col1, col2, Acol, Ignore As Double 'שומר תחילת שורה של מיקום נוכחי Selection.HomeKey Unit:=wdLine Set My = Selection.Range 'בחר את כל העמוד Set WRange = ActiveDocument.Bookmarks("\page").Range 'עובר לתחילת עמוד WRange.SetRange Start:=WRange.Start, End:=WRange.Start + 1 WRange.Select Set Startpage = Selection.Range WRange.SetRange Start:=Startpage.End, End:=My.End 'סופר שורות WRange.Select SLines = Selection.Range.ComputeStatistics(wdStatisticLines) 'חוזר ומפעיל לולאת בדיקה שאין כותרת' My.Select 'Startcol1 מגדיר תחילת טור 1 Set Startcol1 = Selection.Range For S = 1 To SLines - 1 Selection.GoTo What:=wdGoToLine, Which:=wdGoToPrevious, Count:=1, Name:="" If Selection.PageSetup.TextColumns.Count <> 2 Then Exit For Else Set Startcol1 = Selection.Range End If Next 'סוף עמוד Set WRange = ActiveDocument.Bookmarks("\page").Range WRange.SetRange Start:=WRange.End - 1, End:=WRange.End WRange.Select Set Endpage = Selection.Range WRange.SetRange Start:=My.Start, End:=Endpage.End 'סופר שורות WRange.Select ELines = Selection.Range.ComputeStatistics(wdStatisticLines) My.Select 'Endcol2 מגדיר סוף טור 2 Set Endcol2 = Selection.Range For S = 1 To ELines - 1 Selection.GoTo What:=wdGoToLine, Which:=wdGoToNext, Count:=1, Name:="" If Selection.PageSetup.TextColumns.Count <> 2 Then Exit For Else Set Endcol2 = Selection.Range End If Next 'מספר שורות כולל שני טורים Set WRange = Selection.Range WRange.SetRange Start:=Startcol1.End, End:=Endcol2.End WRange.Select NumLines = Selection.Range.ComputeStatistics(wdStatisticLines) ' - col2 מגדיר גובה טור 2 Endcol2.Select col2 = Endcol2.Information(wdVerticalPositionRelativeToPage) Selection.EndKey Unit:=wdLine Set Endcol2 = Selection.Range ' col1מגדיר גובה טור =1 'Endcol1= סוף טור 1 'Startcol2= תחילת טור2 Startcol1.Select For i = 1 To NumLines Selection.GoTo What:=wdGoToLine, Which:=wdGoToNext, Count:=1, Name:="" If col1 > Selection.Information(wdVerticalPositionRelativeToPage) Then Set Startcol2 = Selection.Range Exit For Else col1 = Selection.Information(wdVerticalPositionRelativeToPage) Set Endcol1 = Selection.Range End If Next 'סוף טור 1 = סוף שורה Endcol1.Select Selection.EndKey Unit:=wdLine Set Endcol1 = Selection.Range 'Acol= מגדיר הפרש בין טורים If col1 > col2 Then Acol = col1 - col2 If col1 < col2 Then Acol = col2 - col1 'בודק אם טורים ישרים If Acol < 0.05 Then MsgBox "טורים ישרים" 'אם רווח גדול מידי מוסיף בסוף פסקה מעבר מקטע בטור 1 ElseIf Acol > 30 Then Endcol2.Select ActiveDocument.Range(Start:=Selection.Start, End:=Selection.Start). _ InsertBreak Type:=wdSectionBreakContinuous Selection.Start = Selection.Start + 1 ActiveDocument.Range(Start:=Selection.End, End:=Selection.End).InsertBreak _ Type:=wdSectionBreakContinuous With Selection.PageSetup.TextColumns .SetCount NumColumns:=1 .EvenlySpaced = True .LineBetween = False End With Else 'Pcol1 = מספר פסקאות טור 1 WRange.SetRange Start:=Startcol1.Start, End:=Endcol1.End - 2 WRange.Select Set Rcol1 = Selection.Range Rcol1.Select Pcol1 = (Rcol1.ComputeStatistics(wdStatisticParagraphs)) 'Pcol2 = מספר פסקאות טור 2 WRange.SetRange Start:=Startcol2.Start, End:=Endcol2.End - 2 WRange.Select Set Rcol2 = Selection.Range Rcol2.Select Pcol2 = (Rcol2.ComputeStatistics(wdStatisticParagraphs)) 'טור מרובה פסקאות If Pcol1 > Pcol2 Then 'עורך טור1 ' PPS - מחלק הפרש בין פסקאות PPS = Acol / Pcol1 'עבור לשורה ראשונה בטור Startcol1.Select ' 'אם טור 1 ארוך מ2 If col1 > col2 Then 'בודק אם רווח לא קטן מ2.5 If SpaceAfter - PPS > 2.5 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol1 'מקטין רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter - PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עורך טור 2 Else If Pcol2 = 0 Then 'אחרת עובר עמוד Endcol2.Select Selection.MoveDown wdParagraph, 1 MsgBox ("לא עומד בקרטיונים שנקבעו נא נסה לערוך ידנית") Else PPS = Acol / Pcol2 'עבור לשורה ראשונה בטור 2 Startcol2.Select 'בודק אם רווח לא גדול מ25 If SpaceAfter + PPS < 25 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol2 'מוסיף רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter + PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עובר עמוד Else 'עבור לפסקה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 MsgBox ("לא עומד בקרטיונים שנקבעו נא נסה לערוך ידנית") End If End If End If 'אם טור 2 ארוך מ1 ElseIf col1 < col2 Then 'בודק אם רווח לא גדול מ25 If SpaceAfter + PPS < 25 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol1 'מוסיף רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter + PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת שרווח יהיה גדול מ25 עורך טור 2 Else If Pcol2 = 0 Then 'אחרת עובר עמוד Endcol2.Select Selection.MoveDown wdParagraph, 1 MsgBox ("לא עומד בקרטיונים שנקבעו נא נסה לערוך ידנית") Else PPS = Acol / Pcol2 'עבור לשורה ראשונה בטור 2 Startcol2.Select 'בודק אם רווח לא קטן מ2.5 If SpaceAfter - PPS > 2.5 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol2 'מקטין רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter - PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עובר עמוד Else 'עבור לפסקה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 MsgBox ("לא עומד בקרטיונים שנקבעו נא נסה לערוך ידנית") End If End If End If End If 'אם טור 2 רב פסקאות או שווה ElseIf Pcol2 > Pcol1 Or Pcol2 = Pcol1 Then 'עורך טור 2 'מחלק הפרש בין פסקאות PPS = Acol / Pcol2 'עבור לשורה ראשונה בטור 2 Startcol2.Select 'אם טור 1 ארוך מ2 If col1 > col2 Then 'בודק אם רווח לא גדול מ25 If SpaceAfter + PPS < 25 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol2 'מוסיף רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter + PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עורך טור 1 Else If Pcol1 = 0 Then 'אחרת עובר עמוד Endcol2.Select Selection.MoveDown wdParagraph, 1 MsgBox ("לא עומד בקרטיונים שנקבעו נא נסה לערוך ידנית") Else ' PPS - מחלק הפרש בין פסקאות PPS = Acol / Pcol1 'עבור לשורה ראשונה בטור Startcol1.Select 'בודק אם רווח לא קטן מ2.5 If SpaceAfter - PPS > 2.5 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol1 'מקטין רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter - PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עובר עמוד Else 'עבור לפסקה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 MsgBox ("לא עומד בקרטיונים שנקבעו נא נסה לערוך ידנית") End If End If End If 'אם טור 2 ארוך מ1 ElseIf col2 > col1 Then 'בודק אם רווח לא קטן מ2.5 If SpaceAfter - PPS > 2.5 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol2 'מקטין רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter - PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עורך טור 1 Else If Pcol1 = 0 Then 'אחרת עובר עמוד Endcol2.Select Selection.MoveDown wdParagraph, 1 MsgBox ("לא עומד בקרטיונים שנקבעו נא נסה לערוך ידנית") Else ' PPS - מחלק הפרש בין פסקאות PPS = Acol / Pcol1 'עבור לשורה ראשונה בטור Startcol1.Select 'בודק אם רווח לא גדול מ25 If SpaceAfter + PPS < 25 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol1 'מגדיל רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter + PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עובר עמוד Else 'עבור לפסקה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 MsgBox ("לא עומד בקרטיונים שנקבעו נא נסה לערוך ידנית") End If End If End If End If End If End If My.Select Application.ScreenUpdating = True End Subליישור כל המסמך
Dim WRange, Endcol1, Startcol1, Endcol2, Startcol2, Rcol1, Rcol2 As Range Dim NumLines, WPage, Pcol1, Pcol2, APcol, PPS, a, i, B, C, P, R, S, G, col1, col2, Acol, Ignore As Double Public Sub יישור_טורים_בכל_המסמך_חדש() 'עדכון מסך שקר Application.ScreenUpdating = False 'מספר פסקאות 'תחילה בסוף מסמך מוסיף תו כטור 1 Selection.WholeStory Set Whole = Selection.Range Whole.SetRange Start:=Whole.End, End:=Whole.End Whole.Select If Selection.PageSetup.TextColumns.Count = 2 Then ActiveDocument.Range(Start:=Selection.Start, End:=Selection.Start). _ InsertBreak Type:=wdSectionBreakContinuous Selection.Start = Selection.Start + 1 ActiveDocument.Range(Start:=Selection.End, End:=Selection.End).InsertBreak _ Type:=wdSectionBreakContinuous With Selection.PageSetup.TextColumns .SetCount NumColumns:=1 .EvenlySpaced = True .LineBetween = False End With Else End If 'עובר לפסקה ראשונה ActiveDocument.Paragraphs(1).Range.Select 'נכנס לללואה על כל המסמך For R = 1 To ActiveDocument.Paragraphs.Count / 3 'בודק אם יש שני טורים If Selection.PageSetup.TextColumns.Count = 2 Then Application.Run MacroName:="עורך_טורים" Else Selection.MoveDown wdParagraph, 1 End If Next R Application.ScreenUpdating = True End Sub Public Sub עורך_טורים() 'עדכון מסך שקר Application.ScreenUpdating = False Dim WRange, Endcol2, Startcol1, Rcol1, Rcol2 As Range Dim NumLines, WPage, Pcol1, Pcol2, APcol, PPS, LM, a, i, B, C, P, S, col1, col2, Acol, Ignore As Double 'שומר תחילת שורה של מיקום נוכחי Selection.HomeKey Unit:=wdLine Set My = Selection.Range 'בחר את כל העמוד Set WRange = ActiveDocument.Bookmarks("\page").Range 'עובר לתחילת עמוד WRange.SetRange Start:=WRange.Start, End:=WRange.Start + 1 WRange.Select Set Startpage = Selection.Range WRange.SetRange Start:=Startpage.End, End:=My.End 'סופר שורות WRange.Select SLines = Selection.Range.ComputeStatistics(wdStatisticLines) 'חוזר ומפעיל לולאת בדיקה שאין כותרת' My.Select 'Startcol1 מגדיר תחילת טור 1 Set Startcol1 = Selection.Range For S = 1 To SLines - 1 Selection.GoTo What:=wdGoToLine, Which:=wdGoToPrevious, Count:=1, Name:="" If Selection.PageSetup.TextColumns.Count <> 2 Then Exit For Else Set Startcol1 = Selection.Range End If Next 'סוף עמוד Set WRange = ActiveDocument.Bookmarks("\page").Range WRange.SetRange Start:=WRange.End - 1, End:=WRange.End WRange.Select Set Endpage = Selection.Range WRange.SetRange Start:=My.Start, End:=Endpage.End 'סופר שורות WRange.Select ELines = Selection.Range.ComputeStatistics(wdStatisticLines) My.Select 'Endcol2מגדיר סוף טור 2 Set Endcol2 = Selection.Range For S = 1 To ELines - 1 Selection.GoTo What:=wdGoToLine, Which:=wdGoToNext, Count:=1, Name:="" If Selection.PageSetup.TextColumns.Count <> 2 Then Exit For Else Set Endcol2 = Selection.Range End If Next 'מספר שורות כולל שני טורים Set WRange = Selection.Range WRange.SetRange Start:=Startcol1.End, End:=Endcol2.End WRange.Select NumLines = Selection.Range.ComputeStatistics(wdStatisticLines) ' - col2 מגדיר גובה טור 2 Endcol2.Select col2 = Endcol2.Information(wdVerticalPositionRelativeToPage) Selection.EndKey Unit:=wdLine Set Endcol2 = Selection.Range ' col1מגדיר גובה טור -1 'Endcol1- סוף טור 1 'Startcol2- תחילת טור2 Startcol1.Select For i = 1 To NumLines Selection.GoTo What:=wdGoToLine, Which:=wdGoToNext, Count:=1, Name:="" If col1 > Selection.Information(wdVerticalPositionRelativeToPage) Then Set Startcol2 = Selection.Range Exit For Else col1 = Selection.Information(wdVerticalPositionRelativeToPage) Set Endcol1 = Selection.Range End If Next 'סוף טור 1 = סוף שורה Endcol1.Select Selection.EndKey Unit:=wdLine Set Endcol1 = Selection.Range 'Acol מגדיר הפרש בין טורים If col1 > col2 Then Acol = col1 - col2 If col1 < col2 Then Acol = col2 - col1 'בודק אם טורים ישרים If Acol < 0.05 Then 'עובר לעמודה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 Else 'Pcol1 - מספר פסקאות טור 1 WRange.SetRange Start:=Startcol1.Start, End:=Endcol1.End - 2 WRange.Select Set Rcol1 = Selection.Range Rcol1.Select Pcol1 = (Rcol1.ComputeStatistics(wdStatisticParagraphs)) 'Pcol2 - מספר פסקאות טור 2 WRange.SetRange Start:=Startcol2.Start, End:=Endcol2.End - 2 WRange.Select Set Rcol2 = Selection.Range Rcol2.Select Pcol2 = (Rcol2.ComputeStatistics(wdStatisticParagraphs)) If Pcol1 > Pcol2 Then 'עורך טור1 ' PPS - מחלק הפרש בין פסקאות PPS = Acol / Pcol1 'עבור לשורה ראשונה בטור Startcol1.Select ' 'אם טור 1 ארוך מ2 If col1 > col2 Then 'בודק אם רווח לא קטן מ2.5 If SpaceAfter - PPS > 2.5 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol1 'מקטין רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter - PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עורך טור 2 Else If Pcol2 = 0 Then 'אחרת עובר עמוד Endcol2.Select Selection.MoveDown wdParagraph, 1 Else PPS = Acol / Pcol2 'עבור לשורה ראשונה בטור 2 Startcol2.Select 'בודק אם רווח לא גדול מ25 If SpaceAfter + PPS < 25 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol2 'מוסיף רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter + PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עובר עמוד Else 'עבור לפסקה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 End If End If End If 'אם טור 2 ארוך מ1 ElseIf col1 < col2 Then 'בודק אם רווח לא גדול מ25 If SpaceAfter + PPS < 25 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol1 'מוסיף רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter + PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת שרווח יהיה גדול מ25 עורך טור 2 Else If Pcol2 = 0 Then 'אחרת עובר עמוד Endcol2.Select Selection.MoveDown wdParagraph, 1 Else PPS = Acol / Pcol2 'עבור לשורה ראשונה בטור 2 Startcol2.Select 'בודק אם רווח לא קטן מ2.5 If SpaceAfter - PPS > 2.5 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol2 'מקטין רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter - PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עובר עמוד Else 'עבור לפסקה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 End If End If End If End If 'אם טור 2 רב פסקאות או שווה ElseIf Pcol2 > Pcol1 Or Pcol2 = Pcol1 Then 'עורך טור 2 'מחלק הפרש בין פסקאות PPS = Acol / Pcol2 'עבור לשורה ראשונה בטור 2 Startcol2.Select 'אם טור 1 ארוך מ2 If col1 > col2 Then 'בודק אם רווח לא גדול מ25 If SpaceAfter + PPS < 25 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol2 'מוסיף רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter + PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עורך טור 1 Else If Pcol1 = 0 Then 'אחרת עובר עמוד Endcol2.Select Selection.MoveDown wdParagraph, 1 Else ' PPS - מחלק הפרש בין פסקאות PPS = Acol / Pcol1 'עבור לשורה ראשונה בטור Startcol1.Select 'בודק אם רווח לא קטן מ2.5 If SpaceAfter - PPS > 2.5 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol1 'מקטין רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter - PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עובר עמוד Else 'עבור לפסקה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 End If End If End If 'אם טור 2 ארוך מ1 ElseIf col2 > col1 Then 'בודק אם רווח לא קטן מ2.5 If SpaceAfter - PPS > 2.5 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol2 'מקטין רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter - PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עורך טור 1 Else If Pcol1 = 0 Then 'אחרת עובר עמוד Endcol2.Select Selection.MoveDown wdParagraph, 1 Else ' PPS - מחלק הפרש בין פסקאות PPS = Acol / Pcol1 'עבור לשורה ראשונה בטור Startcol1.Select 'בודק אם רווח לא גדול מ25 If SpaceAfter + PPS < 25 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol1 'מגדיל רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter + PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עובר עמוד Else 'עבור לפסקה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 End If End If End If End If End If 'עובר לעמודה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 End If 'עובר לעמודה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 Application.ScreenUpdating = True End Subושאר הקודים בקובץ המצ"ב
@רפרם-ב-ר-פפא קודם כל תודה רבה על כל השקעות והשיפורים וכו',
משום מה אצלי עובד רק אם לוחצים פעמים, בפעם הראשונה הוא נראה שמריץ באמת את כל הסמך וכו', אבל באמת לא רואים שום שינוי, ורק אם לוחצים עוד פעם, אז עוד פעם מריץ ואז רואים, וזה קורה בין בעמוד זה בלבד ובין בכל המסמך.
ועוד שאלה
ברשימת הפקודות יש כמה אופציות:
ישור טורים בכל המסמך חדש, ויישור כל המסך חדש עורך טורים, מה הבדל ביניהם, ואותו דבר לגבי מכאן עד סוף המסמך.תודה
-
בסייעתא דשמיא
עדכון המאקרו יישור טורים - תוספות ותיקונים
בהמשך להערות וההארות שנכתבו בשרשור זה בסייעתא דשמיא הנני להציע לציבור היקר את מאקרו יישור טורים גרסה 3
א.סודר ענין השגיאה של מרווח פחות מ0
וכמו כן נקבע שמרווח בין פסקאות לא יוכל לחרוג מטווח של 2.5 נקודות מינימום ו25 נקודת מקסימום (וזה לצורך הנראות הבסיסית) ונוסף גם שכשלא מצליח בטור הראשון (שהוא רב בפסקאות לעומת השני) מנסה בטור השני (ואם בשני טורים לא עומד בכללים אז ביישור מסמך שלם או מספר עמודים מדלג באופן אוטומטי לעמוד הבא וביישור עמוד אחד מודיע שלא עומד בכללים שהוצבו)
ב. כמו כן מדלג על מסגרות ותיבות טקסט
(ג. כמו כן מאחר שהוגדר מינימום 2.5 נקודות ממילא לא תהיה בעיה של עובי כתב בכותרת)
ד. נוסף פקודה יישור ממיקום הסמן עד סוף כל המסמך (וטוב במקרה של באג וכו לדלג על המקום הבעייתי)
ה. נוסף פקודה ליישור מכותרת על טור 1 עד כותרת הבאה (דהיינו סימן אחד בקונטרס)
ו. ביישור כל המסמך במקרה שיש כותרת באמצע עמוד מיישר גם את החלק העליון וגם את התחתון
בהצלחה
ואשמח לשמוע אם עובד כמצופה וכן על באגים שלא יהיו וכן הצעות ייעול
נראה שהוא דבר שיכול להועיל להרבה משתמשים ולחסוך זמן לכן אני מקווה לעשות כתוסף לכשיהיה מושלם
וכן בכוונתי להוסיף אפשרות להגדיר את הטווח מינימום ומקסימום ועוד בל"נ
הכל בעזרתו יתברך ובישועתו
מצ"ב הקובץיישור טורים 3.dotm ועודכן בפוסט הראשיוהקוד המתוקן והמשופץ
ליישור עמוד אחדDim WRange, Endcol2, Startcol1, Rcol1, Rcol2 As Range Dim NumLines, WPage, Pcol1, Pcol2, APcol, PPS, a, i, B, C, LM, P, S, V, col1, col2, Acol, Ignore As Double Public Sub יישור_טורים_עמוד_זה() 'בודק אם יש שני טורים If Selection.PageSetup.TextColumns.Count <> 2 Then MsgBox ("לא נמצאו 2 טורים"): Exit Sub 'עדכון מסך שקר Application.ScreenUpdating = False Dim WRange, Endcol2, Startcol1, Rcol1, Rcol2 As Range Dim NumLines, WPage, Pcol1, Pcol2, APcol, PPS, a, i, B, C, LM, P, S, V, col1, col2, Acol, Ignore As Double 'שומר תחילת שורה של מיקום נוכחי Selection.HomeKey Unit:=wdLine Set My = Selection.Range 'בחר את כל העמוד Set WRange = ActiveDocument.Bookmarks("\page").Range 'עובר לתחילת עמוד WRange.SetRange Start:=WRange.Start, End:=WRange.Start + 1 WRange.Select Set Startpage = Selection.Range WRange.SetRange Start:=Startpage.End, End:=My.End 'סופר שורות WRange.Select SLines = Selection.Range.ComputeStatistics(wdStatisticLines) 'חוזר ומפעיל לולאת בדיקה שאין כותרת' My.Select 'Startcol1 מגדיר תחילת טור 1 Set Startcol1 = Selection.Range For S = 1 To SLines - 1 Selection.GoTo What:=wdGoToLine, Which:=wdGoToPrevious, Count:=1, Name:="" If Selection.PageSetup.TextColumns.Count <> 2 Then Exit For Else Set Startcol1 = Selection.Range End If Next 'סוף עמוד Set WRange = ActiveDocument.Bookmarks("\page").Range WRange.SetRange Start:=WRange.End - 1, End:=WRange.End WRange.Select Set Endpage = Selection.Range WRange.SetRange Start:=My.Start, End:=Endpage.End 'סופר שורות WRange.Select ELines = Selection.Range.ComputeStatistics(wdStatisticLines) My.Select 'Endcol2 מגדיר סוף טור 2 Set Endcol2 = Selection.Range For S = 1 To ELines - 1 Selection.GoTo What:=wdGoToLine, Which:=wdGoToNext, Count:=1, Name:="" If Selection.PageSetup.TextColumns.Count <> 2 Then Exit For Else Set Endcol2 = Selection.Range End If Next 'מספר שורות כולל שני טורים Set WRange = Selection.Range WRange.SetRange Start:=Startcol1.End, End:=Endcol2.End WRange.Select NumLines = Selection.Range.ComputeStatistics(wdStatisticLines) ' - col2 מגדיר גובה טור 2 Endcol2.Select col2 = Endcol2.Information(wdVerticalPositionRelativeToPage) Selection.EndKey Unit:=wdLine Set Endcol2 = Selection.Range ' col1מגדיר גובה טור =1 'Endcol1= סוף טור 1 'Startcol2= תחילת טור2 Startcol1.Select For i = 1 To NumLines Selection.GoTo What:=wdGoToLine, Which:=wdGoToNext, Count:=1, Name:="" If col1 > Selection.Information(wdVerticalPositionRelativeToPage) Then Set Startcol2 = Selection.Range Exit For Else col1 = Selection.Information(wdVerticalPositionRelativeToPage) Set Endcol1 = Selection.Range End If Next 'סוף טור 1 = סוף שורה Endcol1.Select Selection.EndKey Unit:=wdLine Set Endcol1 = Selection.Range 'Acol= מגדיר הפרש בין טורים If col1 > col2 Then Acol = col1 - col2 If col1 < col2 Then Acol = col2 - col1 'בודק אם טורים ישרים If Acol < 0.05 Then MsgBox "טורים ישרים" 'אם רווח גדול מידי מוסיף בסוף פסקה מעבר מקטע בטור 1 ElseIf Acol > 30 Then Endcol2.Select ActiveDocument.Range(Start:=Selection.Start, End:=Selection.Start). _ InsertBreak Type:=wdSectionBreakContinuous Selection.Start = Selection.Start + 1 ActiveDocument.Range(Start:=Selection.End, End:=Selection.End).InsertBreak _ Type:=wdSectionBreakContinuous With Selection.PageSetup.TextColumns .SetCount NumColumns:=1 .EvenlySpaced = True .LineBetween = False End With Else 'Pcol1 = מספר פסקאות טור 1 WRange.SetRange Start:=Startcol1.Start, End:=Endcol1.End - 2 WRange.Select Set Rcol1 = Selection.Range Rcol1.Select Pcol1 = (Rcol1.ComputeStatistics(wdStatisticParagraphs)) 'Pcol2 = מספר פסקאות טור 2 WRange.SetRange Start:=Startcol2.Start, End:=Endcol2.End - 2 WRange.Select Set Rcol2 = Selection.Range Rcol2.Select Pcol2 = (Rcol2.ComputeStatistics(wdStatisticParagraphs)) 'טור מרובה פסקאות If Pcol1 > Pcol2 Then 'עורך טור1 ' PPS - מחלק הפרש בין פסקאות PPS = Acol / Pcol1 'עבור לשורה ראשונה בטור Startcol1.Select ' 'אם טור 1 ארוך מ2 If col1 > col2 Then 'בודק אם רווח לא קטן מ2.5 If SpaceAfter - PPS > 2.5 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol1 'מקטין רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter - PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עורך טור 2 Else If Pcol2 = 0 Then 'אחרת עובר עמוד Endcol2.Select Selection.MoveDown wdParagraph, 1 MsgBox ("לא עומד בקרטיונים שנקבעו נא נסה לערוך ידנית") Else PPS = Acol / Pcol2 'עבור לשורה ראשונה בטור 2 Startcol2.Select 'בודק אם רווח לא גדול מ25 If SpaceAfter + PPS < 25 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol2 'מוסיף רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter + PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עובר עמוד Else 'עבור לפסקה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 MsgBox ("לא עומד בקרטיונים שנקבעו נא נסה לערוך ידנית") End If End If End If 'אם טור 2 ארוך מ1 ElseIf col1 < col2 Then 'בודק אם רווח לא גדול מ25 If SpaceAfter + PPS < 25 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol1 'מוסיף רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter + PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת שרווח יהיה גדול מ25 עורך טור 2 Else If Pcol2 = 0 Then 'אחרת עובר עמוד Endcol2.Select Selection.MoveDown wdParagraph, 1 MsgBox ("לא עומד בקרטיונים שנקבעו נא נסה לערוך ידנית") Else PPS = Acol / Pcol2 'עבור לשורה ראשונה בטור 2 Startcol2.Select 'בודק אם רווח לא קטן מ2.5 If SpaceAfter - PPS > 2.5 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol2 'מקטין רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter - PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עובר עמוד Else 'עבור לפסקה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 MsgBox ("לא עומד בקרטיונים שנקבעו נא נסה לערוך ידנית") End If End If End If End If 'אם טור 2 רב פסקאות או שווה ElseIf Pcol2 > Pcol1 Or Pcol2 = Pcol1 Then 'עורך טור 2 'מחלק הפרש בין פסקאות PPS = Acol / Pcol2 'עבור לשורה ראשונה בטור 2 Startcol2.Select 'אם טור 1 ארוך מ2 If col1 > col2 Then 'בודק אם רווח לא גדול מ25 If SpaceAfter + PPS < 25 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol2 'מוסיף רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter + PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עורך טור 1 Else If Pcol1 = 0 Then 'אחרת עובר עמוד Endcol2.Select Selection.MoveDown wdParagraph, 1 MsgBox ("לא עומד בקרטיונים שנקבעו נא נסה לערוך ידנית") Else ' PPS - מחלק הפרש בין פסקאות PPS = Acol / Pcol1 'עבור לשורה ראשונה בטור Startcol1.Select 'בודק אם רווח לא קטן מ2.5 If SpaceAfter - PPS > 2.5 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol1 'מקטין רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter - PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עובר עמוד Else 'עבור לפסקה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 MsgBox ("לא עומד בקרטיונים שנקבעו נא נסה לערוך ידנית") End If End If End If 'אם טור 2 ארוך מ1 ElseIf col2 > col1 Then 'בודק אם רווח לא קטן מ2.5 If SpaceAfter - PPS > 2.5 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol2 'מקטין רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter - PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עורך טור 1 Else If Pcol1 = 0 Then 'אחרת עובר עמוד Endcol2.Select Selection.MoveDown wdParagraph, 1 MsgBox ("לא עומד בקרטיונים שנקבעו נא נסה לערוך ידנית") Else ' PPS - מחלק הפרש בין פסקאות PPS = Acol / Pcol1 'עבור לשורה ראשונה בטור Startcol1.Select 'בודק אם רווח לא גדול מ25 If SpaceAfter + PPS < 25 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol1 'מגדיל רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter + PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עובר עמוד Else 'עבור לפסקה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 MsgBox ("לא עומד בקרטיונים שנקבעו נא נסה לערוך ידנית") End If End If End If End If End If End If My.Select Application.ScreenUpdating = True End Subליישור כל המסמך
Dim WRange, Endcol1, Startcol1, Endcol2, Startcol2, Rcol1, Rcol2 As Range Dim NumLines, WPage, Pcol1, Pcol2, APcol, PPS, a, i, B, C, P, R, S, G, col1, col2, Acol, Ignore As Double Public Sub יישור_טורים_בכל_המסמך_חדש() 'עדכון מסך שקר Application.ScreenUpdating = False 'מספר פסקאות 'תחילה בסוף מסמך מוסיף תו כטור 1 Selection.WholeStory Set Whole = Selection.Range Whole.SetRange Start:=Whole.End, End:=Whole.End Whole.Select If Selection.PageSetup.TextColumns.Count = 2 Then ActiveDocument.Range(Start:=Selection.Start, End:=Selection.Start). _ InsertBreak Type:=wdSectionBreakContinuous Selection.Start = Selection.Start + 1 ActiveDocument.Range(Start:=Selection.End, End:=Selection.End).InsertBreak _ Type:=wdSectionBreakContinuous With Selection.PageSetup.TextColumns .SetCount NumColumns:=1 .EvenlySpaced = True .LineBetween = False End With Else End If 'עובר לפסקה ראשונה ActiveDocument.Paragraphs(1).Range.Select 'נכנס לללואה על כל המסמך For R = 1 To ActiveDocument.Paragraphs.Count / 3 'בודק אם יש שני טורים If Selection.PageSetup.TextColumns.Count = 2 Then Application.Run MacroName:="עורך_טורים" Else Selection.MoveDown wdParagraph, 1 End If Next R Application.ScreenUpdating = True End Sub Public Sub עורך_טורים() 'עדכון מסך שקר Application.ScreenUpdating = False Dim WRange, Endcol2, Startcol1, Rcol1, Rcol2 As Range Dim NumLines, WPage, Pcol1, Pcol2, APcol, PPS, LM, a, i, B, C, P, S, col1, col2, Acol, Ignore As Double 'שומר תחילת שורה של מיקום נוכחי Selection.HomeKey Unit:=wdLine Set My = Selection.Range 'בחר את כל העמוד Set WRange = ActiveDocument.Bookmarks("\page").Range 'עובר לתחילת עמוד WRange.SetRange Start:=WRange.Start, End:=WRange.Start + 1 WRange.Select Set Startpage = Selection.Range WRange.SetRange Start:=Startpage.End, End:=My.End 'סופר שורות WRange.Select SLines = Selection.Range.ComputeStatistics(wdStatisticLines) 'חוזר ומפעיל לולאת בדיקה שאין כותרת' My.Select 'Startcol1 מגדיר תחילת טור 1 Set Startcol1 = Selection.Range For S = 1 To SLines - 1 Selection.GoTo What:=wdGoToLine, Which:=wdGoToPrevious, Count:=1, Name:="" If Selection.PageSetup.TextColumns.Count <> 2 Then Exit For Else Set Startcol1 = Selection.Range End If Next 'סוף עמוד Set WRange = ActiveDocument.Bookmarks("\page").Range WRange.SetRange Start:=WRange.End - 1, End:=WRange.End WRange.Select Set Endpage = Selection.Range WRange.SetRange Start:=My.Start, End:=Endpage.End 'סופר שורות WRange.Select ELines = Selection.Range.ComputeStatistics(wdStatisticLines) My.Select 'Endcol2מגדיר סוף טור 2 Set Endcol2 = Selection.Range For S = 1 To ELines - 1 Selection.GoTo What:=wdGoToLine, Which:=wdGoToNext, Count:=1, Name:="" If Selection.PageSetup.TextColumns.Count <> 2 Then Exit For Else Set Endcol2 = Selection.Range End If Next 'מספר שורות כולל שני טורים Set WRange = Selection.Range WRange.SetRange Start:=Startcol1.End, End:=Endcol2.End WRange.Select NumLines = Selection.Range.ComputeStatistics(wdStatisticLines) ' - col2 מגדיר גובה טור 2 Endcol2.Select col2 = Endcol2.Information(wdVerticalPositionRelativeToPage) Selection.EndKey Unit:=wdLine Set Endcol2 = Selection.Range ' col1מגדיר גובה טור -1 'Endcol1- סוף טור 1 'Startcol2- תחילת טור2 Startcol1.Select For i = 1 To NumLines Selection.GoTo What:=wdGoToLine, Which:=wdGoToNext, Count:=1, Name:="" If col1 > Selection.Information(wdVerticalPositionRelativeToPage) Then Set Startcol2 = Selection.Range Exit For Else col1 = Selection.Information(wdVerticalPositionRelativeToPage) Set Endcol1 = Selection.Range End If Next 'סוף טור 1 = סוף שורה Endcol1.Select Selection.EndKey Unit:=wdLine Set Endcol1 = Selection.Range 'Acol מגדיר הפרש בין טורים If col1 > col2 Then Acol = col1 - col2 If col1 < col2 Then Acol = col2 - col1 'בודק אם טורים ישרים If Acol < 0.05 Then 'עובר לעמודה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 Else 'Pcol1 - מספר פסקאות טור 1 WRange.SetRange Start:=Startcol1.Start, End:=Endcol1.End - 2 WRange.Select Set Rcol1 = Selection.Range Rcol1.Select Pcol1 = (Rcol1.ComputeStatistics(wdStatisticParagraphs)) 'Pcol2 - מספר פסקאות טור 2 WRange.SetRange Start:=Startcol2.Start, End:=Endcol2.End - 2 WRange.Select Set Rcol2 = Selection.Range Rcol2.Select Pcol2 = (Rcol2.ComputeStatistics(wdStatisticParagraphs)) If Pcol1 > Pcol2 Then 'עורך טור1 ' PPS - מחלק הפרש בין פסקאות PPS = Acol / Pcol1 'עבור לשורה ראשונה בטור Startcol1.Select ' 'אם טור 1 ארוך מ2 If col1 > col2 Then 'בודק אם רווח לא קטן מ2.5 If SpaceAfter - PPS > 2.5 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol1 'מקטין רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter - PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עורך טור 2 Else If Pcol2 = 0 Then 'אחרת עובר עמוד Endcol2.Select Selection.MoveDown wdParagraph, 1 Else PPS = Acol / Pcol2 'עבור לשורה ראשונה בטור 2 Startcol2.Select 'בודק אם רווח לא גדול מ25 If SpaceAfter + PPS < 25 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol2 'מוסיף רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter + PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עובר עמוד Else 'עבור לפסקה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 End If End If End If 'אם טור 2 ארוך מ1 ElseIf col1 < col2 Then 'בודק אם רווח לא גדול מ25 If SpaceAfter + PPS < 25 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol1 'מוסיף רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter + PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת שרווח יהיה גדול מ25 עורך טור 2 Else If Pcol2 = 0 Then 'אחרת עובר עמוד Endcol2.Select Selection.MoveDown wdParagraph, 1 Else PPS = Acol / Pcol2 'עבור לשורה ראשונה בטור 2 Startcol2.Select 'בודק אם רווח לא קטן מ2.5 If SpaceAfter - PPS > 2.5 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol2 'מקטין רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter - PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עובר עמוד Else 'עבור לפסקה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 End If End If End If End If 'אם טור 2 רב פסקאות או שווה ElseIf Pcol2 > Pcol1 Or Pcol2 = Pcol1 Then 'עורך טור 2 'מחלק הפרש בין פסקאות PPS = Acol / Pcol2 'עבור לשורה ראשונה בטור 2 Startcol2.Select 'אם טור 1 ארוך מ2 If col1 > col2 Then 'בודק אם רווח לא גדול מ25 If SpaceAfter + PPS < 25 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol2 'מוסיף רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter + PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עורך טור 1 Else If Pcol1 = 0 Then 'אחרת עובר עמוד Endcol2.Select Selection.MoveDown wdParagraph, 1 Else ' PPS - מחלק הפרש בין פסקאות PPS = Acol / Pcol1 'עבור לשורה ראשונה בטור Startcol1.Select 'בודק אם רווח לא קטן מ2.5 If SpaceAfter - PPS > 2.5 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol1 'מקטין רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter - PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עובר עמוד Else 'עבור לפסקה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 End If End If End If 'אם טור 2 ארוך מ1 ElseIf col2 > col1 Then 'בודק אם רווח לא קטן מ2.5 If SpaceAfter - PPS > 2.5 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol2 'מקטין רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter - PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עורך טור 1 Else If Pcol1 = 0 Then 'אחרת עובר עמוד Endcol2.Select Selection.MoveDown wdParagraph, 1 Else ' PPS - מחלק הפרש בין פסקאות PPS = Acol / Pcol1 'עבור לשורה ראשונה בטור Startcol1.Select 'בודק אם רווח לא גדול מ25 If SpaceAfter + PPS < 25 Then 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol1 'מגדיל רווח אחרי פסקה With Selection For B = 1 To .Paragraphs.Count .Paragraphs(B).Format.SpaceAfter = .Paragraphs(B).Format.SpaceAfter + PPS Next B End With 'עבור לפסקה הבאה Selection.MoveDown wdParagraph, 1 Next P 'אחרת עובר עמוד Else 'עבור לפסקה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 End If End If End If End If End If 'עובר לעמודה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 End If 'עובר לעמודה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 Application.ScreenUpdating = True End Subושאר הקודים בקובץ המצ"ב
@רפרם-ב-ר-פפא
שוב תודה על תודה רבה על כל העבודה והמאמצים והכל בחינם, תודה, אצלי עובד טוב כל עוד שתחילת הטור הבא אין כותרות משנה (שהם עצמם גם בשתי טורים) אבל כשיש כותרת שם כזה:
לא מתקן את זה (אני יודע, שזה בעיה מסוג אחר, שאין מספיק מקום להכניס את הכותרת שצמודה לפסקה הבא וכו') אני רק שואל אם אמור לפתור גם כאלה דברים.והנה עוד שאלה/בקשה: אני מנסה לכתוב מאקרו ליישור טורים בעצמי (אני רוצה בעצמי כמה סיבות, אחד כי אני מתלמד בVBA ושתיים כי אני מעדיף להשתמש בפקודות שאני כתבתי, שהם יותר ברורים לי, אני יודע מה בדיוק הם עושים ולמה, ומה המגבלות שלהם, ולשנות אותם לפי הצורך, אבל כאן אני נתקתי בחלק היצירתי, לא בחלק של הקידוד, דהיינו אם הייתי עושה את זה ידני, מה הייתי מנסה לעשות.
אז אבקש אם זה לא טירחה גדולה, האם אתה יכול להסביר לי מה בדיוק אתה מנסה לעשות עם הקוד שלך, שמה יעשה ולפי איזה פרמטרים , ניסיתי לעבור עליו כבר כמה וכמה פעמים, (כמה ימים) ואני נאבד שם, מה בדיוק אתה רוצה לעשות, כלומר אני לא שואל על חלק של התיכנות, זה אני כבר אסתדר איך לכתוב אותו, אבל מה אתה רוצה לצוות למחשב שיעשה, שימדוד הפרשים ואז מה, איך יפתור את הבעיה, יפזר אותו בין השורות, או בין הפסיקאות, או מה,
אשמח אם תוכל לפרט לי, (שוב אני לא צריך שתסביר את כל קוד) תודה -
@רפרם-ב-ר-פפא לא הבנתי האם הקודים שהבאת בסוף הפוסט או לא
@האדם-החושב הקודים מיועדים להכניס לתבנית שלך או לתבנית ראשית אם אתה לא רוצה להוריד את כל התבנית וכן ללמידה
@menajemmendel א. אצלי עובד גם בפעם ראשונה ותודה על ההארה אבדוק את זה בעזר ה' אם אתה יכול להגדיר בדיוק מה הבעיה אם הוא בכל מסמך או כמות פסקאות וכן כותרות וכו' ב. יישור כל המסמך עורך טורים הוא פקודה פנימית מתוך הראשי שמפעיל אם צריך לערוך ג. אפשר שכיוון שהוא הפרש גדול מידי לא יכול לחלק במגבלת המינימום והמקסימום הפתרון לכאורה לבטל בקרת שורות מיותמות (לא הכנסתי למאקרו שעדיף לא להגיע לזה ולערוך ידנית כמו מרווח בין מילים או שורות במקרה של בעיה כי אינו משהו בנראות ) ולאחר מכן להפעיל שוב
ד. לתועלת הציבור אפרט בקצרה מה המאקרו עושה תחילה מגדיר איפה מתחיל טור (דהיינו תחילת שני טורים ועוצר במקום שיש לפניה כותרת על טור בודד)וכן סוף שני טורים ולאחר מכן מגדיר גובה כל אחד מהם וממילא ההפרש ולאחר שקיבל את ההפרש אם אינו ישר בודק באיזה טור יש יותר פסקאות (וזה לצורך הנראות) ועורך את הטור רב הפסקאות מחלק את ההפרש בין הפסקאות (-1 שהוא הסוף שעובר לעמוד הבא) ומפעיל לולאה כפול מספר פסקאות ומוסיף את התוצאה לכל פסקא וכמו כן לפני כן בודק אם התוצאה של המרווח לא תהיה מעל 25 או מתחת2.5 ואם כן מנסה לערוך את הטור השני (שהוא אינו רב בפסקאות) ואם גם שם לא עומד בכללים שנקבעו מדלג לעמוד הבא או מודיע שאינו עומד בקרטיונים
נ.ב. בענין המגבלת טווח ניתן לערוך ידנית למי שמבין קצת בVBA לחפש איפה כתוב 2.5 או25 ולשנות לרצוי מקווה בעזרת ה' שבקרוב יהיה טופס מסודר להגדיר טווח
בתקווה שעזרתי והועלתי לכולם -
@האדם-החושב הקודים מיועדים להכניס לתבנית שלך או לתבנית ראשית אם אתה לא רוצה להוריד את כל התבנית וכן ללמידה
@menajemmendel א. אצלי עובד גם בפעם ראשונה ותודה על ההארה אבדוק את זה בעזר ה' אם אתה יכול להגדיר בדיוק מה הבעיה אם הוא בכל מסמך או כמות פסקאות וכן כותרות וכו' ב. יישור כל המסמך עורך טורים הוא פקודה פנימית מתוך הראשי שמפעיל אם צריך לערוך ג. אפשר שכיוון שהוא הפרש גדול מידי לא יכול לחלק במגבלת המינימום והמקסימום הפתרון לכאורה לבטל בקרת שורות מיותמות (לא הכנסתי למאקרו שעדיף לא להגיע לזה ולערוך ידנית כמו מרווח בין מילים או שורות במקרה של בעיה כי אינו משהו בנראות ) ולאחר מכן להפעיל שוב
ד. לתועלת הציבור אפרט בקצרה מה המאקרו עושה תחילה מגדיר איפה מתחיל טור (דהיינו תחילת שני טורים ועוצר במקום שיש לפניה כותרת על טור בודד)וכן סוף שני טורים ולאחר מכן מגדיר גובה כל אחד מהם וממילא ההפרש ולאחר שקיבל את ההפרש אם אינו ישר בודק באיזה טור יש יותר פסקאות (וזה לצורך הנראות) ועורך את הטור רב הפסקאות מחלק את ההפרש בין הפסקאות (-1 שהוא הסוף שעובר לעמוד הבא) ומפעיל לולאה כפול מספר פסקאות ומוסיף את התוצאה לכל פסקא וכמו כן לפני כן בודק אם התוצאה של המרווח לא תהיה מעל 25 או מתחת2.5 ואם כן מנסה לערוך את הטור השני (שהוא אינו רב בפסקאות) ואם גם שם לא עומד בכללים שנקבעו מדלג לעמוד הבא או מודיע שאינו עומד בקרטיונים
נ.ב. בענין המגבלת טווח ניתן לערוך ידנית למי שמבין קצת בVBA לחפש איפה כתוב 2.5 או25 ולשנות לרצוי מקווה בעזרת ה' שבקרוב יהיה טופס מסודר להגדיר טווח
בתקווה שעזרתי והועלתי לכולם@רפרם-ב-ר-פפא
תודה רבה על ההסבר המפורט, ולגבי השאלה הא' שלא עובד בפעם הראשונה, זה קורה בין בכל המסמך ובין רק בעמוד זה, וגם בדפים שאין לי כותרות -
אולי תוכל לעשות מאקרו דומה לפתרון בעיה נוספת של וורד:
במסמך שיש בו הרבה הערות שולים העימוד האוטמטי של וורד גורם לכך שפיסקה בסוף העמוד הראשון שאין מקום להערת שולים שלה בעמוד זה שכל הפיסקה עוברת לעמוד השני, וכן מעוד הרבה סיבות לפעמים הוורד מעביר קטע מסוף העמוד הראשון לתחילת העמוד השני וכתוצאה מכך נוצר חלל ריק בעמוד הראשון.
ולכן צריך לעשות מאקרו שיזהה את החלל הריק הזה וירחיב את הרווחים בין הפיסקאות בעמוד הראשון וכך לא יהיה חלל ריק.
תודה מראש -
אולי תוכל לעשות מאקרו דומה לפתרון בעיה נוספת של וורד:
במסמך שיש בו הרבה הערות שולים העימוד האוטמטי של וורד גורם לכך שפיסקה בסוף העמוד הראשון שאין מקום להערת שולים שלה בעמוד זה שכל הפיסקה עוברת לעמוד השני, וכן מעוד הרבה סיבות לפעמים הוורד מעביר קטע מסוף העמוד הראשון לתחילת העמוד השני וכתוצאה מכך נוצר חלל ריק בעמוד הראשון.
ולכן צריך לעשות מאקרו שיזהה את החלל הריק הזה וירחיב את הרווחים בין הפיסקאות בעמוד הראשון וכך לא יהיה חלל ריק.
תודה מראש@ASDF1345
כעיקרון המאקרו עושה גם את זה אם הבנתי נכון את כוונתך אלא שבמקרה וההפרש גדול ממילא הרווחים יצטרכו להיות גדולים והוגדר מקסימום מרווח 30 נק' (וזה בשביל הנראות הבסיסית ) אתה יכול לשנות את זה ידנית בקוד
בהצלחה -
@ASDF1345
כעיקרון המאקרו עושה גם את זה אם הבנתי נכון את כוונתך אלא שבמקרה וההפרש גדול ממילא הרווחים יצטרכו להיות גדולים והוגדר מקסימום מרווח 30 נק' (וזה בשביל הנראות הבסיסית ) אתה יכול לשנות את זה ידנית בקוד
בהצלחהפוסט זה נמחק! -
ה האדם החושב התייחס לנושא זה ב
-
לרפרם היקר, תודה ויישר כל על היישור טורים הנפלא, רציתי לשאול, הרי הספרים שאני מעמד מחולקים בד"כ לקטעים, ואם המקטע הבא הוא באותו עמוד ה'מאקרו' לא אוחז שצריך ליישר אותו והוא מיישר רק את סופי העמודים, באופן שצריך לעשות יישור טורים לכל קטע בפני עצמו ע"י האופציה של 'מכותרת לכותרת' רציתי לשאול אם יש לזה פתרון טוב.
תודה מראש. -
לרפרם היקר, תודה ויישר כל על היישור טורים הנפלא, רציתי לשאול, הרי הספרים שאני מעמד מחולקים בד"כ לקטעים, ואם המקטע הבא הוא באותו עמוד ה'מאקרו' לא אוחז שצריך ליישר אותו והוא מיישר רק את סופי העמודים, באופן שצריך לעשות יישור טורים לכל קטע בפני עצמו ע"י האופציה של 'מכותרת לכותרת' רציתי לשאול אם יש לזה פתרון טוב.
תודה מראש.@ישיבישע-amp-amp-amp-amp-x27-ר
שלום
אם מדובר שיש באמצע העמוד כותרת בפריסה של טור 1 המאקרו מזהה אותו ומיישר את שני חלקי העמודים בנפרד
אשמח לשמוע היכן כן נתקלת בבעיה ביישור טורים בחלק מן העמוד
בהצלחה -
@רפרם-ב-ר-פפא כתב בשיתוף | יישור טורים מאקרו חדש!!!:
@א-מ
בתוך מסגרת אי אפשר לעשות שני טורים לכן מחזיר שגיאה
לא הבנתי מה אתה רוצה ליישר בעמוד איזה שני טורים יש לך שם שאינם ישריםיש שם שני טורים בעמוד, לא חשוב.
תודה בכל אופן.@שקוע-בלימוד-0 כתב בשיתוף | יישור טורים מאקרו חדש!!!:
@א-מ איך עשית את ה'צורת הדף'?
עם "עזרים לוורד".
פוסט זה נמחק! -
@רפרם-ב-ר-פפא
התקנתי את המאקרו, וכשאני לוחץ על 'הפעל', מופיעה לי תקלה זו
מה עשיתי לא טוב?
תודה רבה רבה! -
@רפרם-ב-ר-פפא
התקנתי את המאקרו, וכשאני לוחץ על 'הפעל', מופיעה לי תקלה זו
מה עשיתי לא טוב?
תודה רבה רבה!@ישראל-כהן
יש לך שני טורים במסמך? -
@ישראל-כהן
יש לך שני טורים במסמך? -
@ישראל-כהן
תנסה את התוסף שלי
https://mitmachim.top/post/626904 -
@ישראל-כהן
תנסה את התוסף שלי
https://mitmachim.top/post/626904@pcinfogmach כתב בשיתוף | יישור טורים מאקרו חדש!!!:
@ישראל-כהן
תנסה את התוסף שלי
https://mitmachim.top/post/626904התקנתי, ומופיעה לי תיבה שכתוב בה כך:
"לא ניתן למצוא את המאקרו או שהוא אינו זמין בשל הגדרות אבטחת המאקרו".ניסיתי את כל מה שכתבת פה, https://mitmachim.top/topic/63879/להורדה-תוסף-לוורד-תוסף-עיצוב-תורני/2?_=1711318572441
וזה עדיין לא עזר.
מה עוד יכול להיות? -
@pcinfogmach כתב בשיתוף | יישור טורים מאקרו חדש!!!:
@ישראל-כהן
תנסה את התוסף שלי
https://mitmachim.top/post/626904התקנתי, ומופיעה לי תיבה שכתוב בה כך:
"לא ניתן למצוא את המאקרו או שהוא אינו זמין בשל הגדרות אבטחת המאקרו".ניסיתי את כל מה שכתבת פה, https://mitmachim.top/topic/63879/להורדה-תוסף-לוורד-תוסף-עיצוב-תורני/2?_=1711318572441
וזה עדיין לא עזר.
מה עוד יכול להיות?@ישראל-כהן
לא יודע סליחה.
אתה יכול הלעתיק משם את המאקרו ולהשתמש בו -
@ישראל-כהן
לא יודע סליחה.
אתה יכול הלעתיק משם את המאקרו ולהשתמש בו@pcinfogmach כתב בשיתוף | יישור טורים מאקרו חדש!!!:
@ישראל-כהן
לא יודע סליחה.
אתה יכול הלעתיק משם את המאקרו ולהשתמש בוהוא לא נותן לי בכלל לצפות במאקרו. הוא כאילו כלל לא קיים. (גם כשאני לוחץ "צעד לתוך", המסך פשוט נסגר).
בכל אופן, תודה על הכל.
(יש מצב לשלוח לי בפרטי את המאקרו הזה?) -
@רפרם-ב-ר-פפא
התקנתי את המאקרו, וכשאני לוחץ על 'הפעל', מופיעה לי תקלה זו
מה עשיתי לא טוב?
תודה רבה רבה!@ישראל-כהן
יש לך תיבת טקסט או מסגרת במסמך? -
@pcinfogmach כתב בשיתוף | יישור טורים מאקרו חדש!!!:
@ישראל-כהן
תנסה את התוסף שלי
https://mitmachim.top/post/626904התקנתי, ומופיעה לי תיבה שכתוב בה כך:
"לא ניתן למצוא את המאקרו או שהוא אינו זמין בשל הגדרות אבטחת המאקרו".ניסיתי את כל מה שכתבת פה, https://mitmachim.top/topic/63879/להורדה-תוסף-לוורד-תוסף-עיצוב-תורני/2?_=1711318572441
וזה עדיין לא עזר.
מה עוד יכול להיות?@ישראל-כהן
עשית את זה?פתח את לוח הבקרה: ניתן לגשת ללוח הבקרה על ידי חיפוש בתיבת החיפוש של Windows "לוח הבקרה". בלוח הבקרה, תמצא את האפשרות המסומנת "שעה ואזור" ולחץ עליה. כעת לחץ על "אזור": בחלון "אזור", ישנם מספר כרטיסיות בחלק העליון. לחץ על כרטיסיית "ניהולי". לחץ על "שינוי אזור מערכת...": בכרטיסיית "מנהלי", יש כפתור המסומן "שינוי אזור מערכת...". לחץ עליו. בחר עברית (ישראל): בחלון הקופץ, גלול ברשימה עד שתמצא "עברית (ישראל)". בחר את האפשרות הזו. לחץ על אישור ואז הפעל את המחשב מחדש: -
@ישראל-כהן
יש לך תיבת טקסט או מסגרת במסמך?@רפרם-ב-ר-פפא כתב בשיתוף | יישור טורים מאקרו חדש!!!:
@ישראל-כהן
יש לך תיבת טקסט או מסגרת במסמך?אכן. יש לי מסגרת מסביב לתיבה הראשונה.
חשבתי שזו יכולה להיות הבעיה. אבל מאידך, אם אני יישר את הטורים, ורק לאחר מכן אעשה את המסגרת הזו, יכול מאד להיות שיישור הטורים ישתבש, (כיון שלפעמים אחרי שהמילה הראשונה תגדל, היא תדחוף את המילה האחרונה בשורה לשורה הבאה וכו', וכך לפעמים תתווסף שורה בסוף הקטע). אין לזה פתרון?
תודה ענקית על הכל!
 { const baseUrl = "https://www.google.co.il/search?q=site:mitmachim.top"; const m = location.pathname.match(/^\/(topic|category)\/(\d+)/); const type = m ? m[1] : null; const id = m ? m[2] : null; let searchInput; function search(path = "") { const query = searchInput.value.trim(); if (query) { window.open(`${baseUrl}${path}%20${encodeURIComponent(query)}`, "_blank"); } } let buttons = {}; buttons.searchAll = { id: "bb-search-all", label: `חיפוש ${type ? "בכל הפורום" : ""}`, className: type ? "btn-secondary" : "btn-primary", callback: () => search(), }; if (type === "topic") { buttons.searchTopic = { label: "חיפוש בנושא זה", className: "btn-primary", callback: () => search(`/topic/${id}`), }; } else if (type === "category") { buttons.searchCategory = { label: "חיפוש בקטגוריה זו", className: "btn-primary", callback: () => search(`/category/${id}`), }; } buttons.cancel = { label: "ביטול", className: "btn-default", "data-bs-dismiss": "modal" }; const dialog = bootbox.dialog({ title: '<div style="text-align:center;"><img src="/assets/uploads/files/1625950269825-mt-google.png" width="400" alt="חיפוש בגוגל"></div>', message: '<input id="bb-inp" class="bootbox-input bootbox-input-text form-control" placeholder="הקלידו כדי לחפש בגוגל" autocomplete="off"/>', buttons, backdrop: true, show: true, onEscape: true }); dialog.on("shown.bs.modal", function () { searchInput = document.getElementById("bb-inp"); if (searchInput) { searchInput.focus(); searchInput.addEventListener("keydown", function (e) { if (e.key === "Enter") { e.preventDefault(); const query = this.value.trim(); if (query) { search(); dialog.modal("hide"); } } else if (e.key === "Escape") { e.preventDefault(); dialog.modal("hide"); } }); } const searchAllButton = document.getElementById("bb-search-all"); if (searchAllButton) { searchAllButton.title = "לחצו על אנטר כדי לחפש"; } }); })(); void 0;){kind=link}