שיתוף | יישור טורים מאקרו חדש!!!
-
לאחר טיפול במאקרו הנני להציע לפני הציבור
את העדכון למאקרו להחלת יישור על כל המסמך
אשמח להערות הארות וכו'
להלן הקובץ עדכנתי גם בפוסט הראשון
יישור טורים2.dotm
וכן הקוד ליישור לכל המסמךDim WRange, Endcol1, Startcol1, Endcol2, Startcol2, Rcol1, Rcol2 As Range Dim NumLines, WPage, Pcol1, Pcol2, APcol, PPS, a, i, B, C, P, 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 'נכנס לללואה על כל המסמך Dim oPara As Paragraph For Each oPara In ActiveDocument.Paragraphs 'בודק אם יש שני טורים If Selection.PageSetup.TextColumns.Count <> 2 Then Selection.MoveDown wdParagraph, 1 Else Application.Run MacroName:="עורך_טורים" End If Next oPara 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, 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 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol1 'אם If col1 > col2 Then 'מקטין רווח אחרי פסקה 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 ElseIf col1 < col2 Then 'מוסיף רווח אחרי פסקה 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 End If Next P 'עובר לעמודה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 ElseIf Pcol2 > Pcol1 Then 'עורך טור 2 'מחלק הפרש בין פסקאות PPS = Acol / Pcol2 'עבור לשורה ראשונה בטור 2 Startcol2.Select 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol2 If col1 > col2 Then 'מוסיף רווח אחרי פסקה 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 ElseIf col2 > 0 Then 'מקטין רווח אחרי פסקה 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 End If Next P 'עובר לעמודה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 Else 'עובר לעמודה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 End If End If Application.ScreenUpdating = True End Subבהצלחה
@רפרם-ב-ר-פפא כתב בשיתוף | יישור טורים מאקרו חדש!!!:
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כדאי להוסיף בדיקה האם יש כבר מעבר מקטע.
-
@רפרם-ב-ר-פפא כתב בשיתוף | יישור טורים מאקרו חדש!!!:
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כדאי להוסיף בדיקה האם יש כבר מעבר מקטע.
@מאקרו
עשיתי בדיקה בשאלה אם הוא עדיין שני טורים אז עשה מעבר מקטע
אחרת ללא פעולה
כדלהלןIf Selection.PageSetup.TextColumns.Count = 2 Thenתודה ואם יש לך עצה אחרת בשביל הענין האמור או אחר אשמח לשמוע
-
@מאקרו
עשיתי בדיקה בשאלה אם הוא עדיין שני טורים אז עשה מעבר מקטע
אחרת ללא פעולה
כדלהלןIf Selection.PageSetup.TextColumns.Count = 2 Thenתודה ואם יש לך עצה אחרת בשביל הענין האמור או אחר אשמח לשמוע
@רפרם-ב-ר-פפא נכון אבל זה יכול להוסיף מעבר מקטע כפול, זה לא כ"כ קריטי אבל חשבתי בשביל שיהיה יותר מקצועי ולא יוסיף סתם דברים שאינם נצרכים.
-
@רפרם-ב-ר-פפא נכון אבל זה יכול להוסיף מעבר מקטע כפול, זה לא כ"כ קריטי אבל חשבתי בשביל שיהיה יותר מקצועי ולא יוסיף סתם דברים שאינם נצרכים.
@מאקרו
איזה הרצת בדיקה אם יש מעבר מקטע אתה מציע? -
@מאקרו
איזה הרצת בדיקה אם יש מעבר מקטע אתה מציע?@רפרם-ב-ר-פפא אולי לעשות חיפוש של תו מעבר מקטע, יש הרבה רעיוות...
-
לאחר טיפול במאקרו הנני להציע לפני הציבור
את העדכון למאקרו להחלת יישור על כל המסמך
אשמח להערות הארות וכו'
להלן הקובץ עדכנתי גם בפוסט הראשון
יישור טורים2.dotm
וכן הקוד ליישור לכל המסמךDim WRange, Endcol1, Startcol1, Endcol2, Startcol2, Rcol1, Rcol2 As Range Dim NumLines, WPage, Pcol1, Pcol2, APcol, PPS, a, i, B, C, P, 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 'נכנס לללואה על כל המסמך Dim oPara As Paragraph For Each oPara In ActiveDocument.Paragraphs 'בודק אם יש שני טורים If Selection.PageSetup.TextColumns.Count <> 2 Then Selection.MoveDown wdParagraph, 1 Else Application.Run MacroName:="עורך_טורים" End If Next oPara 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, 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 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol1 'אם If col1 > col2 Then 'מקטין רווח אחרי פסקה 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 ElseIf col1 < col2 Then 'מוסיף רווח אחרי פסקה 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 End If Next P 'עובר לעמודה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 ElseIf Pcol2 > Pcol1 Then 'עורך טור 2 'מחלק הפרש בין פסקאות PPS = Acol / Pcol2 'עבור לשורה ראשונה בטור 2 Startcol2.Select 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol2 If col1 > col2 Then 'מוסיף רווח אחרי פסקה 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 ElseIf col2 > 0 Then 'מקטין רווח אחרי פסקה 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 End If Next P 'עובר לעמודה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 Else 'עובר לעמודה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 End If End If Application.ScreenUpdating = True End Subבהצלחה
@רפרם-ב-ר-פפא כתב בשיתוף | יישור טורים מאקרו חדש!!!:
'נכנס לללואה על כל המסמך Dim oPara As Paragraph For Each oPara In ActiveDocument.Paragraphsהייתי ממליץ להפעיל את הלולאה על האובייקט Breaks כדי לקצר את משך הלולאה שלא תעבור על כל פיסקה ופיסקה.
-
לאחר טיפול במאקרו הנני להציע לפני הציבור
את העדכון למאקרו להחלת יישור על כל המסמך
אשמח להערות הארות וכו'
להלן הקובץ עדכנתי גם בפוסט הראשון
יישור טורים2.dotm
וכן הקוד ליישור לכל המסמךDim WRange, Endcol1, Startcol1, Endcol2, Startcol2, Rcol1, Rcol2 As Range Dim NumLines, WPage, Pcol1, Pcol2, APcol, PPS, a, i, B, C, P, 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 'נכנס לללואה על כל המסמך Dim oPara As Paragraph For Each oPara In ActiveDocument.Paragraphs 'בודק אם יש שני טורים If Selection.PageSetup.TextColumns.Count <> 2 Then Selection.MoveDown wdParagraph, 1 Else Application.Run MacroName:="עורך_טורים" End If Next oPara 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, 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 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol1 'אם If col1 > col2 Then 'מקטין רווח אחרי פסקה 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 ElseIf col1 < col2 Then 'מוסיף רווח אחרי פסקה 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 End If Next P 'עובר לעמודה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 ElseIf Pcol2 > Pcol1 Then 'עורך טור 2 'מחלק הפרש בין פסקאות PPS = Acol / Pcol2 'עבור לשורה ראשונה בטור 2 Startcol2.Select 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol2 If col1 > col2 Then 'מוסיף רווח אחרי פסקה 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 ElseIf col2 > 0 Then 'מקטין רווח אחרי פסקה 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 End If Next P 'עובר לעמודה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 Else 'עובר לעמודה הבאה Endcol2.Select Selection.MoveDown wdParagraph, 1 End If End If Application.ScreenUpdating = True End Subבהצלחה
-
@רפרם-ב-ר-פפא החלתי את המאקרו על פיסקה עם מסגרת (כבתמונה) וזה החזיר את שגיאה הבאה:
יש לך אולי דרך לסדר גם את זה?
תזכו למצוות!@א-מ
בתוך מסגרת אי אפשר לעשות שני טורים לכן מחזיר שגיאה
לא הבנתי מה אתה רוצה ליישר בעמוד איזה שני טורים יש לך שם שאינם ישרים -
@רפרם-ב-ר-פפא החלתי את המאקרו על פיסקה עם מסגרת (כבתמונה) וזה החזיר את שגיאה הבאה:
יש לך אולי דרך לסדר גם את זה?
תזכו למצוות!@א-מ איך עשית את ה'צורת הדף'?
-
@א-מ
בתוך מסגרת אי אפשר לעשות שני טורים לכן מחזיר שגיאה
לא הבנתי מה אתה רוצה ליישר בעמוד איזה שני טורים יש לך שם שאינם ישרים@רפרם-ב-ר-פפא כתב בשיתוף | יישור טורים מאקרו חדש!!!:
@א-מ
בתוך מסגרת אי אפשר לעשות שני טורים לכן מחזיר שגיאה
לא הבנתי מה אתה רוצה ליישר בעמוד איזה שני טורים יש לך שם שאינם ישריםיש שם שני טורים בעמוד, לא חשוב.
תודה בכל אופן.@שקוע-בלימוד-0 כתב בשיתוף | יישור טורים מאקרו חדש!!!:
@א-מ איך עשית את ה'צורת הדף'?
עם "עזרים לוורד".
-
חדש! מאקרו ליישור טורים
והפעם בקוד פתוח לצורך שיפור המאקרו ע"י כל החברים
להערות הארות נא לדווח
וכן כל דבר שיכול לשפר את הפעולה
מצורף קובץ תבנית וורד אם אפשרות ליישור עמוד 1 או יישור כל המסמך
עדכון אדר תשפ"ג
יישור טורים 3.dotmוכן הקוד שכתבתי
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, 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 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 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 > 50 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 ElseIf Acol > 0.05 Then '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 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol1 'אם If col1 > col2 Then 'מקטין רווח אחרי פסקה 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 ElseIf col1 < col2 Then 'מוסיף רווח אחרי פסקה 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 End If Next Else 'עורך טור 2 'מחלק הפרש בין פסקאות PPS = Acol / Pcol2 'עבור לשורה ראשונה בטור 2 Startcol2.Select 'מפעיל פקודת תיקון בלולאה *מס' פסקאות For P = 1 To Pcol2 If col1 > col2 Then 'מוסיף רווח אחרי פסקה 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 ElseIf col1 < col2 Then 'מקטין רווח אחרי פסקה 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 End If Next End If End If Application.ScreenUpdating = True End Sub@רפרם-ב-ר-פפא
קודם כל יישר כח על העזרה כזה דבר יכול לחסוך המון זמן לאנשים ויש לו ביקוש אדיר
ניסיתי את המאקרו וניתקלתי בשגיאה
מצו"ב
באג מאקרו יישור טורים.pdf
למעשה המאקרו גם לא הצליח כ"כ מצו"ב דוגמא
יישור טורים לא מוצלח.docmושוב תודה
-
@רפרם-ב-ר-פפא
קודם כל יישר כח על העזרה כזה דבר יכול לחסוך המון זמן לאנשים ויש לו ביקוש אדיר
ניסיתי את המאקרו וניתקלתי בשגיאה
מצו"ב
באג מאקרו יישור טורים.pdf
למעשה המאקרו גם לא הצליח כ"כ מצו"ב דוגמא
יישור טורים לא מוצלח.docmושוב תודה
@pcinfogmach
מכיוון שיש במסמך שלך הרבה קטעים וממילא הרבה מעברי מקטע השינויים רבים יותר וההפרש גובה גדול יותר ולכן לאחר שמחשב את חלוקת היתרה בין טור אחד לשני ומחלק בין הקטעים לפעמים נוצר ששורה האחרונה עוברת לעמוד הבא ולהיפך
ובאמת צריך לתקן שיבדוק אם עובר את סך הנקודות של גובה שורה יחשב את זה ויתנהג בהתאם
אולי כשיהיה איתותי בידי אעשה משהו בעניין
על כל פנים בכמות קטעים ממוצעת בספר רגיל (אין בעיות בכאלו בדרך כלל לא נתקלתי)
בהצלחה -
@pcinfogmach
מכיוון שיש במסמך שלך הרבה קטעים וממילא הרבה מעברי מקטע השינויים רבים יותר וההפרש גובה גדול יותר ולכן לאחר שמחשב את חלוקת היתרה בין טור אחד לשני ומחלק בין הקטעים לפעמים נוצר ששורה האחרונה עוברת לעמוד הבא ולהיפך
ובאמת צריך לתקן שיבדוק אם עובר את סך הנקודות של גובה שורה יחשב את זה ויתנהג בהתאם
אולי כשיהיה איתותי בידי אעשה משהו בעניין
על כל פנים בכמות קטעים ממוצעת בספר רגיל (אין בעיות בכאלו בדרך כלל לא נתקלתי)
בהצלחה@רפרם-ב-ר-פפא
קודם כל תודה רבה שלקחת זמן לענות לי ניסיתי במסמך עם פחות מקטעים ועדיין לא הצליח כ"כ מצו"ב
דוגמא 2.docxאגב מה עם הבאג?
תודה מראש
אברך אותך ואת זמנך היקר המוקדש לזיכוי הרבים שתזכה להרבה סייעתא דשמיא -
@רפרם-ב-ר-פפא
קודם כל תודה רבה שלקחת זמן לענות לי ניסיתי במסמך עם פחות מקטעים ועדיין לא הצליח כ"כ מצו"ב
דוגמא 2.docxאגב מה עם הבאג?
תודה מראש
אברך אותך ואת זמנך היקר המוקדש לזיכוי הרבים שתזכה להרבה סייעתא דשמיא@pcinfogmach
א. השינוי בין הטורים לא נובע מרווח בין פסקאות (הרווח שווה ל0) אלא משינוי גודל של חלק מן המילים
וכשיש רווח בין פסקאות אז יכול לשנות את הרווח לפי ההפרש בין טורים וממילא מתחייס לשינוי גודל אות וכשיש רווח 0 לא יכול לשנות כלל
ובעניין הבאג לא הבנתי על מה מדובר הקובץ שהעלית לא נפתח לי
בהצלחה -
@רפרם-ב-ר-פפא
אה! יפה מאוד!
אז היישור טורים עובד רק אם אין כותרות...
הצורה לפתור את הבעיה של הכותרות היא על ידי הגדרת מרווח בין שורות (בהגדרות פיסקה) ל- מדוייק. אולי כדאי להוסיף את זה למאקרו.בקשר לבאג מצו"ב: (תכל'ס המאקרו עובד גם עם הבאג רק קצת מעצבן שיש הודעת שגיאה:
-
@רפרם-ב-ר-פפא
אה! יפה מאוד!
אז היישור טורים עובד רק אם אין כותרות...
הצורה לפתור את הבעיה של הכותרות היא על ידי הגדרת מרווח בין שורות (בהגדרות פיסקה) ל- מדוייק. אולי כדאי להוסיף את זה למאקרו.בקשר לבאג מצו"ב: (תכל'ס המאקרו עובד גם עם הבאג רק קצת מעצבן שיש הודעת שגיאה:
@pcinfogmach
המאקרו עובד גם אם יש כותרות אלא כשאין מה לחלק הוא לא יכול לחלק ולהוסיף או להוריד כי מחשבן את המרוח בין פסקאות ומחלק ו0 שווה 0
ובעניין הבאג הוא כיוון שלפעמים יש צורך בחלוקה מתחת ל0 (כגון שהמרווח בין פסקאות 10 וישנם שני פסקאות והפרש בין טורים 25 וכשמחלק להוריד 12.5 לכל מקטע נתקע שאינו יכול להיות פחות מ0
ובדרך כלל לא מגיע לזה ועוד יש לי רעיון בעניין ובעז"ה אם יואיל למישהו אעשה כשיהיה איתותי בידי
בהצלחה ובהנאה -
@pcinfogmach
המאקרו עובד גם אם יש כותרות אלא כשאין מה לחלק הוא לא יכול לחלק ולהוסיף או להוריד כי מחשבן את המרוח בין פסקאות ומחלק ו0 שווה 0
ובעניין הבאג הוא כיוון שלפעמים יש צורך בחלוקה מתחת ל0 (כגון שהמרווח בין פסקאות 10 וישנם שני פסקאות והפרש בין טורים 25 וכשמחלק להוריד 12.5 לכל מקטע נתקע שאינו יכול להיות פחות מ0
ובדרך כלל לא מגיע לזה ועוד יש לי רעיון בעניין ובעז"ה אם יואיל למישהו אעשה כשיהיה איתותי בידי
בהצלחה ובהנאה@רפרם-ב-ר-פפא
כן וודאי שהמאקרו עובד גם כשיש כותרות העיה היתה עם גודל שונה של מילים והפתרון כנ"ל על ידי רווח מדוייק שלא נותן למילים גדולות להשפיע על המסמך
לכן המלצתי להוסיף למאקרוושוב יישר כח על המאקרו הנפלא אתה לא יודע כמה זמן חסכת לי ולחברים רק חבל שלא ידעתי על זה עד עכשיו
-
@רפרם-ב-ר-פפא
כן וודאי שהמאקרו עובד גם כשיש כותרות העיה היתה עם גודל שונה של מילים והפתרון כנ"ל על ידי רווח מדוייק שלא נותן למילים גדולות להשפיע על המסמך
לכן המלצתי להוסיף למאקרוושוב יישר כח על המאקרו הנפלא אתה לא יודע כמה זמן חסכת לי ולחברים רק חבל שלא ידעתי על זה עד עכשיו
@pcinfogmach גם כשיש גודל שונה של מילים עובד
רק כשמרווח בין פסקאות הוא 0 לא יכול לחלק ולגרום ליישור טורים
ושמרווח בין פסקאות הוא שווה יותר מ0 יכול לטפל ולחלק את ההפרש בין הטורים לבין הפסקאות וממילא הטור מתיישר אפילו כשיש מילים יותר גדולות
ובכן הרעיון שלך נכון ובעז"ה הוסיף למאקרו שכשמרווח בין פסקאות הוא 0 שיהיה גם מדויק
בהצלחה -
@pcinfogmach גם כשיש גודל שונה של מילים עובד
רק כשמרווח בין פסקאות הוא 0 לא יכול לחלק ולגרום ליישור טורים
ושמרווח בין פסקאות הוא שווה יותר מ0 יכול לטפל ולחלק את ההפרש בין הטורים לבין הפסקאות וממילא הטור מתיישר אפילו כשיש מילים יותר גדולות
ובכן הרעיון שלך נכון ובעז"ה הוסיף למאקרו שכשמרווח בין פסקאות הוא 0 שיהיה גם מדויק
בהצלחה@רפרם-ב-ר-פפא
אלוף! ושוב תודה -
@pcinfogmach גם כשיש גודל שונה של מילים עובד
רק כשמרווח בין פסקאות הוא 0 לא יכול לחלק ולגרום ליישור טורים
ושמרווח בין פסקאות הוא שווה יותר מ0 יכול לטפל ולחלק את ההפרש בין הטורים לבין הפסקאות וממילא הטור מתיישר אפילו כשיש מילים יותר גדולות
ובכן הרעיון שלך נכון ובעז"ה הוסיף למאקרו שכשמרווח בין פסקאות הוא 0 שיהיה גם מדויק
בהצלחה@רפרם-ב-ר-פפא
תודה רבה על המאקרו הנפלא!
מופיע לי גם כן השגיאה שהמרווח הוא 0
יש אפשרות לשנות את זה במסמך עצמו? אני לא יודע איפה זה קורה פשוט..
אין לי אינטרס שזה יהיה 0 או משהו...
או לחילופין יש אפשרות שימשיך להריץ את המאקרו מהעמוד שבו הוא לא הצליח והלאה? זה פשוט מפסיק באחד העמודים הראשונים ומשם ואילך אני צריך לעבוד ידנית אחד אחד..
 { 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}