עזרה בחיפוש ובחירה בוורד

[א. יעקבוביץ 0]

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

מצורף קובץ לדוג' מתוך הקונטרס.
______פרק ראשון ערוך.docx

[מניין]

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

[א. יעקבוביץ 0]

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

[מניין]

@א.-יעקבוביץ-0 כתב בעזרה בחיפוש ובחירה בוורד:

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

כן

[menajemmendel]

@א.-יעקבוביץ-0 זה נשמע משהו שמתאים ל''עבודת נמלים בוורד''
https://sites.google.com/view/chachamim/בית?authuser=0
אם אתה מעוניין אתה מזומן לפנות למייל שלי בפרופיל

[שלמה11]

@א.-יעקבוביץ-0 השקעתי בך...

Spoiler

רק הערה קטנה:
הקובץ הזה לא מסודר בעליל הוא מלא במעברי שורה ומקטע שלא במקומם

הסבר קצר על הקוד:
מכניסים את השם של הרב (כולל המילה "הרב")
מחפש את השם של הרב כולל מעבר שורה לפני ואחרי השם (בכדי להימנע משמות שמופיעים בתוך הטקסט)
מרחיב את הטווח שנמצא אחורה, עד המילה "הרב" שיש מעבר שורה לפניה
מעתיק את הטווח לקובץ חדש
וחוזר חלילה...

באגים:
לא מסתדר עם "מורנו ראש הכולל" (אולי תחליף ל"הרב ראש הכולל")
לא מסתדר עם ההערה הראשונה
מקוה שאין עוד...

Sub מצא_את_הערות_הרב()

    Dim rng As Range
    Dim rng2 As Range
    Dim findRng As Range
    Dim findText() As String
    Dim ravName As String
    Dim newDoc As Document
    Dim i As Integer
    
    ravName = InputBox("הכנס את שם הרב")
    ravName = Chr(13) & ravName & Chr(13)
    
    Set rng = ActiveDocument.Range
    Set rng2 = ActiveDocument.Range
    rng.Start = Search(rng.Duplicate, Chr(13) & "הרב", True).Start
    rng2.End = Search(rng2.Duplicate, Chr(13) & "הרב", True).Start
    Set findRng = rng.Duplicate
    
    Do Until findRng Is Nothing
        i = i + 1
        Set findRng = Search(rng.Duplicate, ravName, True)
        If findRng Is Nothing Then Exit Do
        rng2.End = findRng.Start
        With findRng
            If Not Search(rng2.Duplicate, Chr(13) & "הרב", False) Is Nothing Then
                .Start = Search(rng2.Duplicate, Chr(13) & "הרב", False).End
            End If
            .MoveStartUntil Chr(13)
            .MoveStart wdCharacter, 1
        End With
        ReDim Preserve findText(i)
        findText(i) = findRng.text
        rng.Start = findRng.End
    Loop
    
    Set newDoc = Documents.Add
    If i = 1 Then Exit Sub
    For i = LBound(findText) To UBound(findText)
        With newDoc.Range
            .InsertAfter Chr(13) & findText(i)
            .Collapse wdCollapseEnd
        End With
    Next i
End Sub
Function Search(rng As Range, text As String, forwardOption As Boolean) As Range
    
    With rng.Find
        .ClearFormatting
        .text = text
        .Forward = forwardOption
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        If .Execute Then
            Set Search = rng.Duplicate
        End If
        
    End With
End Function

[pcinfogmach]

@מניין כתב בעזרה בחיפוש ובחירה בוורד:

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

אפשר להעביר לפני על ידי חיפוש והחלפה בשני שלבים
שלב א

אם נדרש משהו יותר מסויים אפשר לשלב את המילה הרב עם תווים כלליים וכיו"ב.

שלב ב

[א. יעקבוביץ 0]

@שלמה11 כתב בעזרה בחיפוש ובחירה בוורד:

השקעתי בך...

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

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

Sub ExportSectionsByAuthor()
    Dim para As Paragraph
    Dim paraText As String
    Dim currentAuthor As Variant
    Dim authors As Variant
    Dim docDict As Object
    Dim newDoc As Document
    Dim pendingText As String
    Dim i As Long

    ' רשימת כל שמות הכותבים במסמך
    authors = Array( _
        "הרב משה כהן", _
        "הרב ישראל הירשמן", _
        "הרב ברוך גודלבסקי", _
        "הרב שלום מרדכי ובר", _
        "הרב אהרן יעקובוביץ", _
        "הרב דוד ישראלי", _
        "הרב שמעון לוי", _
        "הרב צבי וינגורט", _
        "הרב אברהם ישעיהו לוין", _
        "הרב נחמן פישר", _
        "מורנו ראש הכולל שליט""א" _
    )

    ' יצירת מילון לאגירת טקסטים לכל כותב
    Set docDict = CreateObject("Scripting.Dictionary")
    For i = 0 To UBound(authors)
        docDict.Add authors(i), ""
    Next i

    pendingText = ""

    ' מעבר על כל פסקה במסמך
    For Each para In ActiveDocument.Paragraphs
        paraText = para.Range.Text
        Dim foundAuthor As String
        foundAuthor = ""

        ' בדיקה האם הפסקה מכילה את שם אחד הכותבים
        For i = 0 To UBound(authors)
            If InStr(paraText, authors(i)) > 0 Then
                foundAuthor = authors(i)
                Exit For
            End If
        Next i

        If foundAuthor <> "" Then
            ' הפסקה היא של חתימה – יש לשייך את הטקסט שנצבר למי שהופיע בה
            docDict(foundAuthor) = docDict(foundAuthor) & pendingText & paraText
            pendingText = "" ' אפס את הצבירה
        Else
            pendingText = pendingText & paraText
        End If
    Next para

    ' שמירה של כל המסמכים
    For Each currentAuthor In docDict.Keys
        If Trim(docDict(currentAuthor)) <> "" Then
            Set newDoc = Documents.Add
            newDoc.Range.Text = docDict(currentAuthor)

            ' ניקוי שם קובץ
            Dim safeName As String
            safeName = currentAuthor
            safeName = Replace(safeName, ":", "-")
            safeName = Replace(safeName, "\", "-")
            safeName = Replace(safeName, "/", "-")
            safeName = Replace(safeName, "*", "-")
            safeName = Replace(safeName, "?", "")
            safeName = Replace(safeName, Chr(34), "")
            safeName = Replace(safeName, "<", "")
            safeName = Replace(safeName, ">", "")
            safeName = Replace(safeName, "|", "")

            newDoc.SaveAs2 FileName:=safeName & ".docx"
            newDoc.Close
        End If
    Next

    MsgBox "המסמכים נוצרו בהצלחה!"
End Sub

[א. יעקבוביץ 0]

@שלמה11 כתב בעזרה בחיפוש ובחירה בוורד:

רק הערה קטנה:
הקובץ הזה לא מסודר בעליל הוא מלא במעברי שורה ומקטע שלא במקומם

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