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

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

ושאר הקודים בקובץ המצ"ב

@HMJE
להלן מאקרו להחלפה לשדה מספור אוטמטי
(מקל על מרוצת הכתיבה)
מחליף את כל מופעי ה"ממ" בשדה seq

לשדה אוטמטי מספרים

Sub החלפה_לשדה_אוטמטי_מספרים()
        
                Selection.HomeKey Unit:=wdStory
                
                    Selection.Find.ClearFormatting
                    Selection.Find.Text = "ממ"
                    Selection.Find.MatchWildcards = True
                    Do While Selection.Find.Execute
                    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "SEQ A", PreserveFormatting:=True
                    Loop

End Sub

לשדה אוטמטי אותיות (א... יא... קא...)

Sub החלפה_לשדה_אוטמטי_אותיות()
        
                Selection.HomeKey Unit:=wdStory
                
                    Selection.Find.ClearFormatting
                    Selection.Find.Text = "ממ"
                    Selection.Find.MatchWildcards = True
                    Do While Selection.Find.Execute
                    Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
        "SEQ A \* hebrew1", PreserveFormatting:=True
                    Loop

End Sub

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

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

קוד למספר רץ במספרים

Sub אאאא_החלפה()
'
' Macro1 Macro
'
'
For I = 1 To 150

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    
    With Selection.Find
        .Text = "ממ"
        .Replacement.Text = I
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
   
    With Selection
        If .Find.Forward = True Then
            .Collapse Direction:=wdCollapseStart
        Else
            .Collapse Direction:=wdCollapseEnd
        End If
        .Find.Execute Replace:=wdReplaceOne
        If .Find.Forward = True Then
            .Collapse Direction:=wdCollapseEnd
        Else
            .Collapse Direction:=wdCollapseStart
        End If
        .Find.Execute
    End With
     Next I
End Sub

הבעיה שצריך לקבוע מראש עד כמה יעשה כי סתם מידי הרבה מכביד על המאקרו

וכמו כן לאותיות כרגע מא- עד ת

Sub אאאא_החלפה()
'
' Macro1 Macro
'
'
For I = 1488 To 1514

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    
    With Selection.Find
        .Text = "ממ"
        .Replacement.Text = ChrW(I)
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
   
    With Selection
        If .Find.Forward = True Then
            .Collapse Direction:=wdCollapseStart
        Else
            .Collapse Direction:=wdCollapseEnd
        End If
        .Find.Execute Replace:=wdReplaceOne
        If .Find.Forward = True Then
            .Collapse Direction:=wdCollapseEnd
        Else
            .Collapse Direction:=wdCollapseStart
        End If
        .Find.Execute
    End With
     Next I
End Sub

וכשמגיע לת גומר את מאקרו
בתקווה שעזרתי
(וכמו כן יכול להיות שאפשר למחוק כמה שורות לא עברתי על זה לעומק)

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

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

בהצלחה

@האדם-החושב הקודים מיועדים להכניס לתבנית שלך או לתבנית ראשית אם אתה לא רוצה להוריד את כל התבנית וכן ללמידה
@menajemmendel א. אצלי עובד גם בפעם ראשונה ותודה על ההארה אבדוק את זה בעזר ה' אם אתה יכול להגדיר בדיוק מה הבעיה אם הוא בכל מסמך או כמות פסקאות וכן כותרות וכו' ב. יישור כל המסמך עורך טורים הוא פקודה פנימית מתוך הראשי שמפעיל אם צריך לערוך ג. אפשר שכיוון שהוא הפרש גדול מידי לא יכול לחלק במגבלת המינימום והמקסימום הפתרון לכאורה לבטל בקרת שורות מיותמות (לא הכנסתי למאקרו שעדיף לא להגיע לזה ולערוך ידנית כמו מרווח בין מילים או שורות במקרה של בעיה כי אינו משהו בנראות ) ולאחר מכן להפעיל שוב
ד. לתועלת הציבור אפרט בקצרה מה המאקרו עושה תחילה מגדיר איפה מתחיל טור (דהיינו תחילת שני טורים ועוצר במקום שיש לפניה כותרת על טור בודד)וכן סוף שני טורים ולאחר מכן מגדיר גובה כל אחד מהם וממילא ההפרש ולאחר שקיבל את ההפרש אם אינו ישר בודק באיזה טור יש יותר פסקאות (וזה לצורך הנראות) ועורך את הטור רב הפסקאות מחלק את ההפרש בין הפסקאות (-1 שהוא הסוף שעובר לעמוד הבא) ומפעיל לולאה כפול מספר פסקאות ומוסיף את התוצאה לכל פסקא וכמו כן לפני כן בודק אם התוצאה של המרווח לא תהיה מעל 25 או מתחת2.5 ואם כן מנסה לערוך את הטור השני (שהוא אינו רב בפסקאות) ואם גם שם לא עומד בכללים שנקבעו מדלג לעמוד הבא או מודיע שאינו עומד בקרטיונים
נ.ב. בענין המגבלת טווח ניתן לערוך ידנית למי שמבין קצת בVBA לחפש איפה כתוב 2.5 או25 ולשנות לרצוי מקווה בעזרת ה' שבקרוב יהיה טופס מסודר להגדיר טווח
בתקווה שעזרתי והועלתי לכולם

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

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

@רק-מה
הנה

Sub החלת_סגנון()
Dim B, I As Double

ActiveDocument.Paragraphs(1).Range.Select
For P = 1 To ActiveDocument.Paragraphs.Count
                   For B = 1 To Selection.Paragraphs.Count
                    Selection.Paragraphs(B).Range.Select
                    Next B
If Selection.PageSetup.TextColumns.Count = 1 And Selection.Range.Bold = True Then
I = I + 1
Selection.Style = ActiveDocument.Styles("כותרת " & I)
Selection.MoveDown wdParagraph, 1
Else
Selection.MoveDown wdParagraph, 1
I = 0
End If
Next P
End Sub

בהצלחה!!!!!

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

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

Sub מספור_מופעים_בוורד()
        
            
                Selection.HomeKey Unit:=wdStory
                
                    Selection.Find.ClearFormatting
                    Selection.Find.Text = "שלום"
                    Selection.Find.MatchWildcards = True
                    Do While Selection.Find.Execute
                         I = I + 1
                    Loop

         MsgBox I
End Sub

@121244
להלן קוד עם ספירה לכמה מילים וסה"כ
אם זה מה שהתכוונת

Sub החלפה_כולל_ספירה()
Dim I, P, K, L, J As Double
arrFind = Array("א", "ב", "ג")
arrReplace = Array("ד", "ה", "ו")
For I = 0 To ActiveDocument.Words.Count
For F = 0 To UBound(arrFind)
'החלפה
    Selection.Find.Text = arrFind(F)
     Selection.Find.Replacement.Text = arrReplace(F)
    Selection.Find.Wrap = wdFindContinue
    Selection.Find.Execute Replace:=wdReplaceOne
    'ספירה
    If Selection.Range = arrReplace(0) Then
    P = P + 1
   ElseIf Selection.Range = arrReplace(1) Then
   K = K + 1
    ElseIf Selection.Range = arrReplace(2) Then
    J = J + 1
  Else
End If
Selection.EndKey Unit:=wdLine
Next F
Next I
'סה''כ
L = P + K + J
'הודעה
 MsgBox arrFind(0) & " " & P & " פעמים " & arrFind(1) & " " & K & " פעמים " & arrFind(2) & " " & J & " פעמים סה''כ החלפות " & L
End Sub

@121244
המאקרו כותב כמה החלפות היו לכל מילה וכמה סה"כ החלפות בפעולה זו
מה הכוונה פקודה שעושה את הפקודה מספר פעמים הפקודה היא לעשות החלפות לכל המסמך עד שלא נשאר מה להחליף
בהצלחה!!!!!!!!!!!!!

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

@שמעון-חבצלת כתב בבקשה | תכלס' מישהוא יודע על תוכנה בעברית לקמפיין פורים חינם?:

כמו"כ לגבי קישור עם נדרים פלוס

יש[כאן] מפורום תחומים
בהצלחה

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

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

@ASDF1345
כעיקרון המאקרו עושה גם את זה אם הבנתי נכון את כוונתך אלא שבמקרה וההפרש גדול ממילא הרווחים יצטרכו להיות גדולים והוגדר מקסימום מרווח 30 נק' (וזה בשביל הנראות הבסיסית ) אתה יכול לשנות את זה ידנית בקוד
בהצלחה