דילוג לתוכן
  • חוקי הפורום
  • פופולרי
  • לא נפתר
  • משתמשים
  • חיפוש גוגל בפורום
  • צור קשר
עיצובים
  • Light
  • Cerulean
  • Cosmo
  • Flatly
  • Journal
  • Litera
  • Lumen
  • Lux
  • Materia
  • Minty
  • Morph
  • Pulse
  • Sandstone
  • Simplex
  • Sketchy
  • Spacelab
  • United
  • Yeti
  • Zephyr
  • Dark
  • Cyborg
  • Darkly
  • Quartz
  • Slate
  • Solar
  • Superhero
  • Vapor

  • ברירת מחדל (ללא עיצוב (ברירת מחדל))
  • ללא עיצוב (ברירת מחדל)
כיווץ
מתמחים טופ
  1. דף הבית
  2. תוכנות
  3. יישומי אופיס
  4. אקסל
  5. VBA - excel
  6. עזרה הדדית - VBA excel
  7. שיתוף | יישור טורים מאקרו חדש!!!

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

מתוזמן נעוץ נעול הועבר עזרה הדדית - VBA excel
61 פוסטים 16 כותבים 2.7k צפיות 18 עוקבים
  • מהישן לחדש
  • מהחדש לישן
  • הכי הרבה הצבעות
תגובה
  • תגובה כנושא
התחברו כדי לפרסם תגובה
נושא זה נמחק. רק משתמשים עם הרשאות מתאימות יוכלו לצפות בו.
  • ר רפרם ב"ר פפא

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

    @רפרם-ב-ר-פפא זו התוצאה שאני מקבל:
    00502d03-6f3c-4cdb-bf53-d567822d1043-image.png

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

    9928bf90-b885-49a6-8745-55377dade570-image.png

    ר תגובה 1 תגובה אחרונה
    1
    • ר רפרם ב"ר פפא

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

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

      צ תגובה 1 תגובה אחרונה
      0
      • ח חיים טבריה

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

        צ מנותק
        צ מנותק
        צדיק וטוב לו 0
        כתב ב נערך לאחרונה על ידי צדיק וטוב לו 0
        #4

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

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

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

        תגובה 1 תגובה אחרונה
        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
          
          ד מנותק
          ד מנותק
          דאנציג
          כתב ב נערך לאחרונה על ידי דאנציג
          #5

          @רפרם-ב-ר-פפא תודה רבה, אבל זה נראה שביישור טורים בכל המסמך משהו תקוע כפי שהעלו קודמי. (אני לא מבין בזה, כך שלצערי איני יכול לעזור, אבל אני חושב ש @NYKUSER או @DMP או @מאקרו יוכלו לעזור).
          לפני שאתה משחרר קוד, תבדוק בכלי המובנה בוז'ואל בייסיק האם הוא פועל כמצופה:
          43addecb-5b56-4bfd-94d6-d6e101ae08c4-image.png
          תזכה למצוות

          תגובה 1 תגובה אחרונה
          0
          • ש מנותק
            ש מנותק
            שמעלקא 0
            כתב ב נערך לאחרונה על ידי
            #6

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

            תגובה 1 תגובה אחרונה
            0
            • א א.מ.

              @רפרם-ב-ר-פפא זו התוצאה שאני מקבל:
              00502d03-6f3c-4cdb-bf53-d567822d1043-image.png

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

              9928bf90-b885-49a6-8745-55377dade570-image.png

              ר מנותק
              ר מנותק
              רפרם ב"ר פפא
              כתב ב נערך לאחרונה על ידי רפרם ב"ר פפא
              #7

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

              צ ר 2 תגובות תגובה אחרונה
              3
              • ר רפרם ב"ר פפא

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

                צ מנותק
                צ מנותק
                צדיק וטוב לו 0
                כתב ב נערך לאחרונה על ידי
                #8
                פוסט זה נמחק!
                תגובה 1 תגובה אחרונה
                0
                • מגדליםמ מגדלים העביר נושא זה מ-עזרה הדדית - וורד ב-
                • ר רפרם ב"ר פפא

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

                  ר מנותק
                  ר מנותק
                  רפרם ב"ר פפא
                  כתב ב נערך לאחרונה על ידי רפרם ב"ר פפא
                  #9

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

                  בהצלחה

                  מ א 3 תגובות תגובה אחרונה
                  3
                  • ר רפרם ב"ר פפא

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

                    בהצלחה

                    מ מנותק
                    מ מנותק
                    מאקרו
                    כתב ב נערך לאחרונה על ידי
                    #10

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

                    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

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

                    ר תגובה 1 תגובה אחרונה
                    0
                    • מ מאקרו

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

                      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

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

                      ר מנותק
                      ר מנותק
                      רפרם ב"ר פפא
                      כתב ב נערך לאחרונה על ידי רפרם ב"ר פפא
                      #11

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

                      If Selection.PageSetup.TextColumns.Count = 2 Then
                      

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

                      מ תגובה 1 תגובה אחרונה
                      0
                      • ר רפרם ב"ר פפא

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

                        If Selection.PageSetup.TextColumns.Count = 2 Then
                        

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

                        מ מנותק
                        מ מנותק
                        מאקרו
                        כתב ב נערך לאחרונה על ידי
                        #12

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

                        ר תגובה 1 תגובה אחרונה
                        1
                        • מ מאקרו

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

                          ר מנותק
                          ר מנותק
                          רפרם ב"ר פפא
                          כתב ב נערך לאחרונה על ידי
                          #13

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

                          מ תגובה 1 תגובה אחרונה
                          0
                          • ר רפרם ב"ר פפא

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

                            מ מנותק
                            מ מנותק
                            מאקרו
                            כתב ב נערך לאחרונה על ידי
                            #14

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

                            תגובה 1 תגובה אחרונה
                            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
                              
                              
                              
                              
                              

                              בהצלחה

                              מ מנותק
                              מ מנותק
                              מאקרו
                              כתב ב נערך לאחרונה על ידי מאקרו
                              #15

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

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

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

                              תגובה 1 תגובה אחרונה
                              1
                              • ר רפרם ב"ר פפא

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

                                בהצלחה

                                א מחובר
                                א מחובר
                                א.מ.
                                מדריכים
                                כתב ב נערך לאחרונה על ידי
                                #16

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

                                b9dda539-0235-4dd6-96f1-18026c7ea31c-image.png
                                eb93104c-db20-4142-97c0-5b6ddceb5086-image.png
                                יש לך אולי דרך לסדר גם את זה?
                                תזכו למצוות!

                                ר ש 2 תגובות תגובה אחרונה
                                0
                                • א א.מ.

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

                                  b9dda539-0235-4dd6-96f1-18026c7ea31c-image.png
                                  eb93104c-db20-4142-97c0-5b6ddceb5086-image.png
                                  יש לך אולי דרך לסדר גם את זה?
                                  תזכו למצוות!

                                  ר מנותק
                                  ר מנותק
                                  רפרם ב"ר פפא
                                  כתב ב נערך לאחרונה על ידי
                                  #17

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

                                  א תגובה 1 תגובה אחרונה
                                  1
                                  • א א.מ.

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

                                    b9dda539-0235-4dd6-96f1-18026c7ea31c-image.png
                                    eb93104c-db20-4142-97c0-5b6ddceb5086-image.png
                                    יש לך אולי דרך לסדר גם את זה?
                                    תזכו למצוות!

                                    ש מנותק
                                    ש מנותק
                                    שקוע בלימוד 0
                                    כתב ב נערך לאחרונה על ידי
                                    #18

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

                                    תגובה 1 תגובה אחרונה
                                    0
                                    • ר רפרם ב"ר פפא

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

                                      א מחובר
                                      א מחובר
                                      א.מ.
                                      מדריכים
                                      כתב ב נערך לאחרונה על ידי
                                      #19

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

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

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

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

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

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

                                      menajemmendelM תגובה 1 תגובה אחרונה
                                      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
                                        
                                        P מנותק
                                        P מנותק
                                        pcinfogmach
                                        מדריכים
                                        כתב ב נערך לאחרונה על ידי
                                        #20

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

                                        ושוב תודה

                                        גמ"ח עזרה וייעוץ בנושאי מחשבים

                                        ר תגובה 1 תגובה אחרונה
                                        0
                                        • P pcinfogmach

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

                                          ושוב תודה

                                          ר מנותק
                                          ר מנותק
                                          רפרם ב"ר פפא
                                          כתב ב נערך לאחרונה על ידי
                                          #21

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

                                          P תגובה 1 תגובה אחרונה
                                          0

                                          • התחברות

                                          • אין לך חשבון עדיין? הרשמה

                                          • התחברו או הירשמו כדי לחפש.
                                          • פוסט ראשון
                                            פוסט אחרון
                                          0
                                          • חוקי הפורום
                                          • פופולרי
                                          • לא נפתר
                                          • משתמשים
                                          • חיפוש גוגל בפורום
                                          • צור קשר