שיתוף | יישור טורים מאקרו חדש!!!

[רפרם ב"ר פפא]

חדש! מאקרו ליישור טורים
והפעם בקוד פתוח לצורך שיפור המאקרו ע"י כל החברים
להערות הארות נא לדווח
וכן כל דבר שיכול לשפר את הפעולה
מצורף קובץ תבנית וורד אם אפשרות ליישור עמוד 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

[א.מ.]

@רפרם-ב-ר-פפא זו התוצאה שאני מקבל:

וכשאני לוחץ על Debug

[חיים טבריה]

@רפרם-ב-ר-פפא גם אני קיבלתי תוצאה כמו @א-מ

[צדיק וטוב לו 0]

@חיים-טבריה כתב בשיתוף | יישור טורים מאקרו חדש!!!:

@רפרם-ב-ר-פפא גם אני קיבלתי תוצאה כמו @א-מ

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

[דאנציג]

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

תזכה למצוות

[שמעלקא 0]

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

[רפרם ב"ר פפא]

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

[צדיק וטוב לו 0]

פוסט זה נמחק!

[רפרם ב"ר פפא]

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

כדאי להוסיף בדיקה האם יש כבר מעבר מקטע.

[רפרם ב"ר פפא]

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

If Selection.PageSetup.TextColumns.Count = 2 Then

תודה ואם יש לך עצה אחרת בשביל הענין האמור או אחר אשמח לשמוע

[מאקרו]

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

[רפרם ב"ר פפא]

@מאקרו
איזה הרצת בדיקה אם יש מעבר מקטע אתה מציע?

[מאקרו]

@רפרם-ב-ר-פפא אולי לעשות חיפוש של תו מעבר מקטע, יש הרבה רעיוות...

[מאקרו]

@רפרם-ב-ר-פפא כתב בשיתוף | יישור טורים מאקרו חדש!!!:

    'נכנס לללואה על כל המסמך
 Dim oPara As Paragraph
     For Each oPara In ActiveDocument.Paragraphs

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

[א.מ.]

@רפרם-ב-ר-פפא החלתי את המאקרו על פיסקה עם מסגרת (כבתמונה) וזה החזיר את שגיאה הבאה:

יש לך אולי דרך לסדר גם את זה?
תזכו למצוות!

[רפרם ב"ר פפא]

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

[שקוע בלימוד 0]

@א-מ איך עשית את ה'צורת הדף'?

[א.מ.]

@רפרם-ב-ר-פפא כתב בשיתוף | יישור טורים מאקרו חדש!!!:

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

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

@שקוע-בלימוד-0 כתב בשיתוף | יישור טורים מאקרו חדש!!!:

@א-מ איך עשית את ה'צורת הדף'?

עם "עזרים לוורד".

[pcinfogmach]

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

ושוב תודה