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

עזרה | מישהו יכול לבדוק לי את המאקרו יישור טורים דלהלן

מתוזמן נעוץ נעול הועבר עזרה הדדית - וורד
29 פוסטים 5 כותבים 459 צפיות 6 עוקבים
  • מהישן לחדש
  • מהחדש לישן
  • הכי הרבה הצבעות
תגובה
  • תגובה כנושא
התחברו כדי לפרסם תגובה
נושא זה נמחק. רק משתמשים עם הרשאות מתאימות יוכלו לצפות בו.
  • P pcinfogmach

    מצו"ב מאקרו חדש ליישור טורים בוורד עבור התוסף לוורד עיצוב תורני אשמח אם מישהו יוכל לבדוק לי את הביצועים שלו

    Option Explicit
    Dim currentPageNumber As Long
     
    Sub AlignColumnsInSelection()
        Dim originalRange As range
        Dim currentPageRange As range, currentSectionRange As range
        Dim startPageNumber As Long, endPageNumber As Long
        Dim currentSection As Section
        
        On Error GoTo errorHandle ' Enable error handling.
        Application.UndoRecord.StartCustomRecord "ééùåø èåøéí"
        
        ' Save the initial selection range to restore it after alignment.
        Set originalRange = Selection.range
        ExpandSelectionToEndOfPageOrSection originalRange
        
        ' Get the first and last page numbers within the selection.
        startPageNumber = originalRange.Characters.First.Information(wdActiveEndPageNumber)
        endPageNumber = originalRange.Characters.Last.Information(wdActiveEndPageNumber)
        
        ' Loop through each page within the selection.
        For currentPageNumber = startPageNumber To endPageNumber
            ' Navigate to the current page.
            Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Name:=currentPageNumber
            Application.ScreenUpdating = False ' Turn off screen updating for better performance.
        
            ' Select the entire content of the current page.
            Set currentPageRange = Selection.Bookmarks("\page").range
            
            ' Process sections within the page, if applicable.
            If currentPageRange.Sections.Count > 1 Then
                For Each currentSection In currentPageRange.Sections
                    Set currentSectionRange = currentSection.range
                    ' Adjust the section range based on the page number.
                    If currentSectionRange.Characters.First.Information(wdActiveEndPageNumber) = currentPageNumber Then
                        currentSectionRange.End = currentPageRange.End
                    ElseIf currentSectionRange.Characters.First.Information(wdActiveEndPageNumber) < currentPageNumber Then
                        currentSectionRange.Start = currentPageRange.Start
                    End If
                    
                    ' Align the section if it has two text columns.
                    If currentSectionRange.PageSetup.TextColumns.Count = 2 And currentSectionRange.InRange(originalRange) Then
                        DoAlignment currentSectionRange
                    End If
                Next currentSection
                
            ElseIf currentPageRange.PageSetup.TextColumns.Count = 2 Then
                ' Align the page if there is only one section.
                DoAlignment currentPageRange
            End If
            
            Application.ScreenUpdating = True 'Re-enable screen updating for visual progress.
            DoEvents ' Allow system events to process to avoid freezing.
        Next currentPageNumber
        
        ' Restore the original selection.
        originalRange.Select
        
        ' End the custom undo record
        Application.UndoRecord.EndCustomRecord
        
        Exit Sub
     
    errorHandle:
    Call ErrorHandler
    End Sub
    Sub ExpandSelectionToEndOfPageOrSection(ByRef originalRange As range)
        ' Declare variables to hold the start and end positions of sections and pages
        Dim endSection, startSection As Long
        Dim endPage, startPage As Long
        
        ' Get the end position of the last section and the start position of the first section in the range
        endSection = originalRange.Sections.Last.range.End
        startSection = originalRange.Sections.First.range.Start
     
        ' Get the page number where the range ends and where it starts
        endPage = originalRange.Characters.Last.Information(wdActiveEndPageNumber)
        startPage = originalRange.Characters.First.Information(wdActiveEndPageNumber)
        
        ' Move the selection to the end page and get the end position of that page
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Name:=endPage
        endPage = Selection.Bookmarks("\page").End
        
        ' Move the selection to the start page and get the start position of that page
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Name:=startPage
        startPage = Selection.Start
        
        ' Extend the range's end position to the end of the section or page, whichever comes first
        If endSection < endPage Then
            If originalRange.End < endSection Then originalRange.End = endSection
        Else
            If originalRange.End < endPage Then originalRange.End = endPage
        End If
        
        ' Extend the range's start position to the start of the section or page, whichever comes last
        If startSection > startPage Then
            If originalRange.Start > startSection Then originalRange.Start = startSection
        Else
            If originalRange.Start > startPage Then originalRange.Start = startPage
        End If
    End Sub
     
     
     
    Sub DoAlignment(ActionRange As range)
        
        Dim firstColumnRange, secondColumnRange As range ' Declare variables for the ranges representing the two columns.
        Dim columnBoundaryX, column1BoundaryY, column2BoundaryY As Double ' Variables to store the column boundary and vertical positions of the columns.
        Dim positionDifference As Single ' Stores the difference in vertical positions to adjust spacing between paragraphs.
        Dim firstColumnBottomMarker, secondColumnBottomMarker As range ' Variables to mark the bottom of each column.
        Dim currentParagraph As Paragraph ' Variable to iterate through the paragraphs.
            
        On Error GoTo errorHandle
        ' Duplicate the selected range to represent the first and second columns.
        Set firstColumnRange = ActionRange.Duplicate
        Set secondColumnRange = ActionRange.Duplicate
        
        ' Determine the column boundary using the horizontal position on the page.
        ActionRange.Select
        With Selection
            .EndKey ' Move the cursor to the end of the selection.
            .HomeKey ' Move the cursor back to the start of the selection.
             columnBoundaryX = .Information(wdHorizontalPositionRelativeToPage) + (.PageSetup.TextColumns(1).SpaceAfter) ' Set the boundary between the columns.
            Set secondColumnBottomMarker = .range ' Store the bottom position of the second column.
        End With
        
        ' Configure the first column range.
        With firstColumnRange
            .Collapse ' Collapse the range to its starting point.
     
            ' Expand the first column range to include paragraphs until it reaches the column boundary.
            Do While .Next(wdParagraph).Characters.Last.Information(wdHorizontalPositionRelativeToPage) > columnBoundaryX
                .MoveEnd wdParagraph, 1 ' Extend the range by one paragraph.
            Loop
            
            ' Fine-tune the boundary by moving character by character until it reaches the column boundary.
            Do While .Next.Information(wdHorizontalPositionRelativeToPage) > columnBoundaryX
                     .MoveEnd wdCharacter, 1 ' Extend the range by one character.
            Loop
     
            secondColumnRange.Start = .End
        End With
        
        ' Select the first column range to capture its bottom position.
        firstColumnRange.Select
        With Selection
            .EndKey ' Move to the end of the first column.
            .HomeKey ' Move back to the start.
        End With
        Set firstColumnBottomMarker = Selection.range ' Store the bottom position of the first column.
        
        ' Retrieve the vertical positions of the bottom markers for both columns.
        column1BoundaryY = firstColumnBottomMarker.Information(wdVerticalPositionRelativeToPage)
        column2BoundaryY = secondColumnBottomMarker.Information(wdVerticalPositionRelativeToPage)
        
        ' Adjust spacing between paragraphs to align the bottoms of both columns.
        ' This loop increases spacing if the first column is shorter.
        Do While column2BoundaryY > column1BoundaryY
            ' Calculate the difference in vertical positions, divided by the number of paragraphs.
            positionDifference = (column2BoundaryY - column1BoundaryY) / firstColumnRange.Paragraphs.Count
            
            ' Exit if the difference is too large or negative.
            If positionDifference > 40 Or positionDifference < 0 Then Exit Do
            
            ' Increase the spacing after each paragraph in the first column.
            For Each currentParagraph In firstColumnRange.Paragraphs
                If currentParagraph.range.Characters.Last.InRange(firstColumnRange) Then
                    currentParagraph.SpaceAfter = currentParagraph.SpaceAfter + positionDifference
                    ' Update the bottom position of the first column.
                     column1BoundaryY = firstColumnBottomMarker.Information(wdVerticalPositionRelativeToPage)
                    ' Exit the loop if the bottom of the first column aligns with the second column.
                    If column1BoundaryY >= column2BoundaryY Then
                        Exit For
                    End If
                End If
            Next currentParagraph
               
        Loop
        
        ' If the second column is shorter, adjust its paragraph spacing similarly.
        Do While column1BoundaryY > column2BoundaryY
            ' Calculate the spacing difference for the second column.
            positionDifference = (column1BoundaryY - column2BoundaryY) / secondColumnRange.Paragraphs.Count
            
            ' Exit if the difference is too large.
            If positionDifference > 40 Then Exit Do
            
            ' Increase the spacing after each paragraph in the second column.
            For Each currentParagraph In secondColumnRange.Paragraphs
                If currentParagraph.range.Characters.Last.InRange(secondColumnRange) Then
                    currentParagraph.range.Select
                    currentParagraph.SpaceAfter = currentParagraph.SpaceAfter + positionDifference
                    ' Update the bottom position of the second column.
                    column2BoundaryY = secondColumnBottomMarker.Information(wdVerticalPositionRelativeToPage)
                    ' Exit the loop if the second column aligns with the first column.
                    If column2BoundaryY >= column1BoundaryY Then Exit For
                End If
            Next currentParagraph
            
        Loop
        
    Exit Sub
    errorHandle:
    Call ErrorHandler
    End Sub
     
    Sub ErrorHandler()
        ' Handle errors and clean up.
        Application.UndoRecord.EndCustomRecord
        Application.ScreenUpdating = True
        
        Dim msg As String
        Debug.Print "Error Number: " & Err.Number & vbCrLf & _
              "Source: " & Err.Source & vbCrLf & _
              "Description: " & Err.Description & vbCrLf & _
              "Help Context: " & Err.HelpContext & vbCrLf & _
              "Help File: " & Err.HelpFile & vbCrLf & _
              "Page Number: " & currentPageNumber
    End Sub
    
    
    י מנותק
    י מנותק
    יאיר הבהיר
    כתב נערך לאחרונה על ידי
    #2

    @pcinfogmach ניסיתי להריץ את הפקודה [העליונה, כן?] ולא עבד לי טוב, הוא ייצר כמה רווחים לא הגיוניים ולא יישר. אין לי מושג אם עשיתי נכון...

    אגב: טוב תעשה אם תשפר את התוסף בקטע הזה כי ביישור טורים הוא נתקע במסמכים גדולים לפעמים, וגם לא תמיד מיישר כמו שצריך, אז ברכות על היוזמה!

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

      @pcinfogmach ניסיתי להריץ את הפקודה [העליונה, כן?] ולא עבד לי טוב, הוא ייצר כמה רווחים לא הגיוניים ולא יישר. אין לי מושג אם עשיתי נכון...

      אגב: טוב תעשה אם תשפר את התוסף בקטע הזה כי ביישור טורים הוא נתקע במסמכים גדולים לפעמים, וגם לא תמיד מיישר כמו שצריך, אז ברכות על היוזמה!

      P מנותק
      P מנותק
      pcinfogmach
      מדריכים
      כתב נערך לאחרונה על ידי
      #3

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

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

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

        מחזיר שגיאה.
        7d5c02a6-dcf0-4caf-8edf-3a7f5f7c8828-image.png

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

          מחזיר שגיאה.
          7d5c02a6-dcf0-4caf-8edf-3a7f5f7c8828-image.png

          P מנותק
          P מנותק
          pcinfogmach
          מדריכים
          כתב נערך לאחרונה על ידי pcinfogmach
          #5

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

          עריכה:
          אוקיי כעת התמונה נפתחה כנראה שיש לך כבר מאקרו בשם זה פשוט תשנה את שם המאקרו למשהו אחר ותריץ אותו

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

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

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

            עריכה:
            אוקיי כעת התמונה נפתחה כנראה שיש לך כבר מאקרו בשם זה פשוט תשנה את שם המאקרו למשהו אחר ותריץ אותו

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

            @pcinfogmach ניסיתי שוב ונראה לי שהוא לא מיישר כלום...
            ‏‏הכתב והמכתב - עותק.docx

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

              @pcinfogmach ניסיתי שוב ונראה לי שהוא לא מיישר כלום...
              ‏‏הכתב והמכתב - עותק.docx

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

              @יאיר-הבהיר
              אוקיי אני רואה מה הבעיה אתה עשית קיפול לספר נכון?

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

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

                @יאיר-הבהיר
                אוקיי אני רואה מה הבעיה אתה עשית קיפול לספר נכון?

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

                @pcinfogmach צודק.
                קשור?

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

                  @pcinfogmach צודק.
                  קשור?

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

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

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

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

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

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

                    @pcinfogmach ניסיתי גם בלי קיפול ספר ועדיין לא עובד לי... 🤔
                    ‏‏הכתב והמכתב - עותק.docx

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

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

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

                      @pcinfogmach אגב, כדאי שתהיה גם פקודה לסוף הקטע, שאם יש קטע שנגמר כך:

                      ab80359b-83b1-4262-aadf-bc4dc3c850ef-image.png

                      אז שיישר אותו כך:

                      89890187-6d68-4450-ad5a-36c587a61dcf-image.png

                      [צריך שיוגדר לו מעבר מקטע מיד בסוף הטקסט, ואז הוא מתיישר כמעט בכל המקרים]

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

                        @pcinfogmach אגב, כדאי שתהיה גם פקודה לסוף הקטע, שאם יש קטע שנגמר כך:

                        ab80359b-83b1-4262-aadf-bc4dc3c850ef-image.png

                        אז שיישר אותו כך:

                        89890187-6d68-4450-ad5a-36c587a61dcf-image.png

                        [צריך שיוגדר לו מעבר מקטע מיד בסוף הטקסט, ואז הוא מתיישר כמעט בכל המקרים]

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

                        @יאיר-הבהיר כתב בעזרה | מישהו יכול לבדוק לי את המאקרו יישור טורים דלהלן:

                        [צריך שיוגדר לו מעבר מקטע מיד בסוף הטקסט, ואז הוא מתיישר כמעט בכל המקרים]

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

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

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

                          @pcinfogmach ניסיתי גם בלי קיפול ספר ועדיין לא עובד לי... 🤔
                          ‏‏הכתב והמכתב - עותק.docx

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

                          @יאיר-הבהיר כתב בעזרה | מישהו יכול לבדוק לי את המאקרו יישור טורים דלהלן:

                          @pcinfogmach ניסיתי גם בלי קיפול ספר ועדיין לא עובד לי...

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

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

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

                            @יאיר-הבהיר כתב בעזרה | מישהו יכול לבדוק לי את המאקרו יישור טורים דלהלן:

                            @pcinfogmach ניסיתי גם בלי קיפול ספר ועדיין לא עובד לי...

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

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

                            @pcinfogmach כתב בעזרה | מישהו יכול לבדוק לי את המאקרו יישור טורים דלהלן:

                            @יאיר-הבהיר כתב בעזרה | מישהו יכול לבדוק לי את המאקרו יישור טורים דלהלן:

                            @pcinfogmach ניסיתי גם בלי קיפול ספר ועדיין לא עובד לי...

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

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

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

                              מצו"ב מאקרו חדש ליישור טורים בוורד עבור התוסף לוורד עיצוב תורני אשמח אם מישהו יוכל לבדוק לי את הביצועים שלו

                              Option Explicit
                              Dim currentPageNumber As Long
                               
                              Sub AlignColumnsInSelection()
                                  Dim originalRange As range
                                  Dim currentPageRange As range, currentSectionRange As range
                                  Dim startPageNumber As Long, endPageNumber As Long
                                  Dim currentSection As Section
                                  
                                  On Error GoTo errorHandle ' Enable error handling.
                                  Application.UndoRecord.StartCustomRecord "ééùåø èåøéí"
                                  
                                  ' Save the initial selection range to restore it after alignment.
                                  Set originalRange = Selection.range
                                  ExpandSelectionToEndOfPageOrSection originalRange
                                  
                                  ' Get the first and last page numbers within the selection.
                                  startPageNumber = originalRange.Characters.First.Information(wdActiveEndPageNumber)
                                  endPageNumber = originalRange.Characters.Last.Information(wdActiveEndPageNumber)
                                  
                                  ' Loop through each page within the selection.
                                  For currentPageNumber = startPageNumber To endPageNumber
                                      ' Navigate to the current page.
                                      Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Name:=currentPageNumber
                                      Application.ScreenUpdating = False ' Turn off screen updating for better performance.
                                  
                                      ' Select the entire content of the current page.
                                      Set currentPageRange = Selection.Bookmarks("\page").range
                                      
                                      ' Process sections within the page, if applicable.
                                      If currentPageRange.Sections.Count > 1 Then
                                          For Each currentSection In currentPageRange.Sections
                                              Set currentSectionRange = currentSection.range
                                              ' Adjust the section range based on the page number.
                                              If currentSectionRange.Characters.First.Information(wdActiveEndPageNumber) = currentPageNumber Then
                                                  currentSectionRange.End = currentPageRange.End
                                              ElseIf currentSectionRange.Characters.First.Information(wdActiveEndPageNumber) < currentPageNumber Then
                                                  currentSectionRange.Start = currentPageRange.Start
                                              End If
                                              
                                              ' Align the section if it has two text columns.
                                              If currentSectionRange.PageSetup.TextColumns.Count = 2 And currentSectionRange.InRange(originalRange) Then
                                                  DoAlignment currentSectionRange
                                              End If
                                          Next currentSection
                                          
                                      ElseIf currentPageRange.PageSetup.TextColumns.Count = 2 Then
                                          ' Align the page if there is only one section.
                                          DoAlignment currentPageRange
                                      End If
                                      
                                      Application.ScreenUpdating = True 'Re-enable screen updating for visual progress.
                                      DoEvents ' Allow system events to process to avoid freezing.
                                  Next currentPageNumber
                                  
                                  ' Restore the original selection.
                                  originalRange.Select
                                  
                                  ' End the custom undo record
                                  Application.UndoRecord.EndCustomRecord
                                  
                                  Exit Sub
                               
                              errorHandle:
                              Call ErrorHandler
                              End Sub
                              Sub ExpandSelectionToEndOfPageOrSection(ByRef originalRange As range)
                                  ' Declare variables to hold the start and end positions of sections and pages
                                  Dim endSection, startSection As Long
                                  Dim endPage, startPage As Long
                                  
                                  ' Get the end position of the last section and the start position of the first section in the range
                                  endSection = originalRange.Sections.Last.range.End
                                  startSection = originalRange.Sections.First.range.Start
                               
                                  ' Get the page number where the range ends and where it starts
                                  endPage = originalRange.Characters.Last.Information(wdActiveEndPageNumber)
                                  startPage = originalRange.Characters.First.Information(wdActiveEndPageNumber)
                                  
                                  ' Move the selection to the end page and get the end position of that page
                                  Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Name:=endPage
                                  endPage = Selection.Bookmarks("\page").End
                                  
                                  ' Move the selection to the start page and get the start position of that page
                                  Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Name:=startPage
                                  startPage = Selection.Start
                                  
                                  ' Extend the range's end position to the end of the section or page, whichever comes first
                                  If endSection < endPage Then
                                      If originalRange.End < endSection Then originalRange.End = endSection
                                  Else
                                      If originalRange.End < endPage Then originalRange.End = endPage
                                  End If
                                  
                                  ' Extend the range's start position to the start of the section or page, whichever comes last
                                  If startSection > startPage Then
                                      If originalRange.Start > startSection Then originalRange.Start = startSection
                                  Else
                                      If originalRange.Start > startPage Then originalRange.Start = startPage
                                  End If
                              End Sub
                               
                               
                               
                              Sub DoAlignment(ActionRange As range)
                                  
                                  Dim firstColumnRange, secondColumnRange As range ' Declare variables for the ranges representing the two columns.
                                  Dim columnBoundaryX, column1BoundaryY, column2BoundaryY As Double ' Variables to store the column boundary and vertical positions of the columns.
                                  Dim positionDifference As Single ' Stores the difference in vertical positions to adjust spacing between paragraphs.
                                  Dim firstColumnBottomMarker, secondColumnBottomMarker As range ' Variables to mark the bottom of each column.
                                  Dim currentParagraph As Paragraph ' Variable to iterate through the paragraphs.
                                      
                                  On Error GoTo errorHandle
                                  ' Duplicate the selected range to represent the first and second columns.
                                  Set firstColumnRange = ActionRange.Duplicate
                                  Set secondColumnRange = ActionRange.Duplicate
                                  
                                  ' Determine the column boundary using the horizontal position on the page.
                                  ActionRange.Select
                                  With Selection
                                      .EndKey ' Move the cursor to the end of the selection.
                                      .HomeKey ' Move the cursor back to the start of the selection.
                                       columnBoundaryX = .Information(wdHorizontalPositionRelativeToPage) + (.PageSetup.TextColumns(1).SpaceAfter) ' Set the boundary between the columns.
                                      Set secondColumnBottomMarker = .range ' Store the bottom position of the second column.
                                  End With
                                  
                                  ' Configure the first column range.
                                  With firstColumnRange
                                      .Collapse ' Collapse the range to its starting point.
                               
                                      ' Expand the first column range to include paragraphs until it reaches the column boundary.
                                      Do While .Next(wdParagraph).Characters.Last.Information(wdHorizontalPositionRelativeToPage) > columnBoundaryX
                                          .MoveEnd wdParagraph, 1 ' Extend the range by one paragraph.
                                      Loop
                                      
                                      ' Fine-tune the boundary by moving character by character until it reaches the column boundary.
                                      Do While .Next.Information(wdHorizontalPositionRelativeToPage) > columnBoundaryX
                                               .MoveEnd wdCharacter, 1 ' Extend the range by one character.
                                      Loop
                               
                                      secondColumnRange.Start = .End
                                  End With
                                  
                                  ' Select the first column range to capture its bottom position.
                                  firstColumnRange.Select
                                  With Selection
                                      .EndKey ' Move to the end of the first column.
                                      .HomeKey ' Move back to the start.
                                  End With
                                  Set firstColumnBottomMarker = Selection.range ' Store the bottom position of the first column.
                                  
                                  ' Retrieve the vertical positions of the bottom markers for both columns.
                                  column1BoundaryY = firstColumnBottomMarker.Information(wdVerticalPositionRelativeToPage)
                                  column2BoundaryY = secondColumnBottomMarker.Information(wdVerticalPositionRelativeToPage)
                                  
                                  ' Adjust spacing between paragraphs to align the bottoms of both columns.
                                  ' This loop increases spacing if the first column is shorter.
                                  Do While column2BoundaryY > column1BoundaryY
                                      ' Calculate the difference in vertical positions, divided by the number of paragraphs.
                                      positionDifference = (column2BoundaryY - column1BoundaryY) / firstColumnRange.Paragraphs.Count
                                      
                                      ' Exit if the difference is too large or negative.
                                      If positionDifference > 40 Or positionDifference < 0 Then Exit Do
                                      
                                      ' Increase the spacing after each paragraph in the first column.
                                      For Each currentParagraph In firstColumnRange.Paragraphs
                                          If currentParagraph.range.Characters.Last.InRange(firstColumnRange) Then
                                              currentParagraph.SpaceAfter = currentParagraph.SpaceAfter + positionDifference
                                              ' Update the bottom position of the first column.
                                               column1BoundaryY = firstColumnBottomMarker.Information(wdVerticalPositionRelativeToPage)
                                              ' Exit the loop if the bottom of the first column aligns with the second column.
                                              If column1BoundaryY >= column2BoundaryY Then
                                                  Exit For
                                              End If
                                          End If
                                      Next currentParagraph
                                         
                                  Loop
                                  
                                  ' If the second column is shorter, adjust its paragraph spacing similarly.
                                  Do While column1BoundaryY > column2BoundaryY
                                      ' Calculate the spacing difference for the second column.
                                      positionDifference = (column1BoundaryY - column2BoundaryY) / secondColumnRange.Paragraphs.Count
                                      
                                      ' Exit if the difference is too large.
                                      If positionDifference > 40 Then Exit Do
                                      
                                      ' Increase the spacing after each paragraph in the second column.
                                      For Each currentParagraph In secondColumnRange.Paragraphs
                                          If currentParagraph.range.Characters.Last.InRange(secondColumnRange) Then
                                              currentParagraph.range.Select
                                              currentParagraph.SpaceAfter = currentParagraph.SpaceAfter + positionDifference
                                              ' Update the bottom position of the second column.
                                              column2BoundaryY = secondColumnBottomMarker.Information(wdVerticalPositionRelativeToPage)
                                              ' Exit the loop if the second column aligns with the first column.
                                              If column2BoundaryY >= column1BoundaryY Then Exit For
                                          End If
                                      Next currentParagraph
                                      
                                  Loop
                                  
                              Exit Sub
                              errorHandle:
                              Call ErrorHandler
                              End Sub
                               
                              Sub ErrorHandler()
                                  ' Handle errors and clean up.
                                  Application.UndoRecord.EndCustomRecord
                                  Application.ScreenUpdating = True
                                  
                                  Dim msg As String
                                  Debug.Print "Error Number: " & Err.Number & vbCrLf & _
                                        "Source: " & Err.Source & vbCrLf & _
                                        "Description: " & Err.Description & vbCrLf & _
                                        "Help Context: " & Err.HelpContext & vbCrLf & _
                                        "Help File: " & Err.HelpFile & vbCrLf & _
                                        "Page Number: " & currentPageNumber
                              End Sub
                              
                              
                              S מנותק
                              S מנותק
                              shishko
                              כתב נערך לאחרונה על ידי
                              #15

                              @pcinfogmach סתם שאלה בקשר לתוסף אולי כדאי לייצר הדגשת מילה ראשונה דרך האפשרות בסינית לשתי שורות באותה שורה, ניסית פעם?

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

                                @pcinfogmach סתם שאלה בקשר לתוסף אולי כדאי לייצר הדגשת מילה ראשונה דרך האפשרות בסינית לשתי שורות באותה שורה, ניסית פעם?

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

                                @shishko
                                לא ניסיתי. אתה ניסית והצליח?

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

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

                                  @shishko
                                  לא ניסיתי. אתה ניסית והצליח?

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

                                  @pcinfogmach לא, בדיוק לפני כמה דקות חשבתי על זה באופן ידני ודאי ניתן לעשות את זה על אף א"א לעשות יישור לסוף השורה ולכן ישנם אי אלו הבדלים חסרון נוסף שניתן לעשו שני שורות רק עם רווח ביניהם של נקודה 1 ולא 1.5 כמו הגדרת ברירת המחדל השאלה אם אין דרך להתגבר על זה?
                                  וגם אם לא אולי ניתן לעשות את זה כאפשרות נוספת כשהמעלה שהמילה הראשונה היא חלק מהטקסט ויותר קל לבטל את זה במיקום מסויים!!
                                  צריך לבדוק אם אפשר בעיקרון להשתמש בזה גם כשאין סינית על המחשב וכל הבעיה שטכנית זה לא מופיע (דרך אגב אם כן אפשר להוסיף את האפשרויות שיש בסינית לתוסף).
                                  אם יהיה לי זמן אני ינסה לעבוד על זה.

                                  P תגובה 1 תגובה אחרונה
                                  2
                                  • S shishko

                                    @pcinfogmach לא, בדיוק לפני כמה דקות חשבתי על זה באופן ידני ודאי ניתן לעשות את זה על אף א"א לעשות יישור לסוף השורה ולכן ישנם אי אלו הבדלים חסרון נוסף שניתן לעשו שני שורות רק עם רווח ביניהם של נקודה 1 ולא 1.5 כמו הגדרת ברירת המחדל השאלה אם אין דרך להתגבר על זה?
                                    וגם אם לא אולי ניתן לעשות את זה כאפשרות נוספת כשהמעלה שהמילה הראשונה היא חלק מהטקסט ויותר קל לבטל את זה במיקום מסויים!!
                                    צריך לבדוק אם אפשר בעיקרון להשתמש בזה גם כשאין סינית על המחשב וכל הבעיה שטכנית זה לא מופיע (דרך אגב אם כן אפשר להוסיף את האפשרויות שיש בסינית לתוסף).
                                    אם יהיה לי זמן אני ינסה לעבוד על זה.

                                    P מנותק
                                    P מנותק
                                    pcinfogmach
                                    מדריכים
                                    כתב נערך לאחרונה על ידי
                                    #18

                                    @shishko
                                    אוקיי תעדכן אותי
                                    ואם תוכל לשלוח לי מאקרו מוכן כמובן הדבר יקל עלי

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

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

                                      @יאיר-הבהיר כתב בעזרה | מישהו יכול לבדוק לי את המאקרו יישור טורים דלהלן:

                                      [צריך שיוגדר לו מעבר מקטע מיד בסוף הטקסט, ואז הוא מתיישר כמעט בכל המקרים]

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

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

                                      @pcinfogmach כתב בעזרה | מישהו יכול לבדוק לי את המאקרו יישור טורים דלהלן:

                                      @יאיר-הבהיר כתב בעזרה | מישהו יכול לבדוק לי את המאקרו יישור טורים דלהלן:

                                      [צריך שיוגדר לו מעבר מקטע מיד בסוף הטקסט, ואז הוא מתיישר כמעט בכל המקרים]

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

                                      ffc2cf7d-3590-4dc3-8af9-c20a05afa16f-bandicam 2024-10-27 01-45-12-677.mp4

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

                                        @pcinfogmach כתב בעזרה | מישהו יכול לבדוק לי את המאקרו יישור טורים דלהלן:

                                        @יאיר-הבהיר כתב בעזרה | מישהו יכול לבדוק לי את המאקרו יישור טורים דלהלן:

                                        @pcinfogmach ניסיתי גם בלי קיפול ספר ועדיין לא עובד לי...

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

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

                                        P מנותק
                                        P מנותק
                                        pcinfogmach
                                        מדריכים
                                        כתב נערך לאחרונה על ידי pcinfogmach
                                        #20

                                        @יאיר-הבהיר
                                        מצאתי שגיאה בקוד שלי אנא נסה כעת בקוד המעודכן

                                        עריכה:
                                        ערכתי עוד כמה דברים בקוד כעת הוא אמור לעבוד גם בקבצים עם קיפול
                                        בדקתי ועבד אצלי על הקובץ שהעלית

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

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

                                          @pcinfogmach כתב בעזרה | מישהו יכול לבדוק לי את המאקרו יישור טורים דלהלן:

                                          @יאיר-הבהיר כתב בעזרה | מישהו יכול לבדוק לי את המאקרו יישור טורים דלהלן:

                                          [צריך שיוגדר לו מעבר מקטע מיד בסוף הטקסט, ואז הוא מתיישר כמעט בכל המקרים]

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

                                          ffc2cf7d-3590-4dc3-8af9-c20a05afa16f-bandicam 2024-10-27 01-45-12-677.mp4

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

                                          @יאיר-הבהיר
                                          קבצים מסוג זה נחסמים בנטפרי אשמח אם תשלח לי במייל בתוך קובץ זיפ

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

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

                                          • התחברות

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

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