שיתוף | "מתעדכן" אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות.

[pcinfogmach]

@דאנציג כתב בשיתוף | "מתעדכן" אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות.:

אבל, בתיבת טקסט שניהם לא עובדים...

ושל שלמה מימות כן?

[דאנציג]

@pcinfogmach כן

[pcinfogmach]

חיפוש והחלפה באבני בניין
חיפוש והחלפה עם אבני בניין.dotm

[mfmf]

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

[שלל]

@דאנציג יכלת גם להגדיר לזה קיצור מקשים מותאם אישית... לשם הידע..

[ASDF1345]

מצורף מסמך שמכיל מספר פקודות מאקרו: א. הפניה מקושרת ב. אינדקס ג. פקודות שקשורות לתצוגת טויטה
עריכה: מצורף קובץ יותר מעודכן מאקרו הפניה מקושרת אינדקס תצוגת טויטה.dotm

[pcinfogmach]

@ASDF1345
מומלץ לציין מה בדיוק השתנה בעדכון

[ASDF1345]

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

[ASDF1345]

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

Sub הוספת_מעבר_עמוד_לפי_סגנון_כל_המסמך()
'
' הוספת_מעבר_עמוד_לפי_סגנון_כל_המסמך Macro
'
'

Application.ScreenUpdating = False

Selection.Find.ClearFormatting
SIGNON = Selection.Style

Dim my_undo As Object
Set my_undo = Application.UndoRecord
my_undo.StartCustomRecord ("הוספת מעבר עמוד לפי סגנון")
On Error GoTo ending

Dim rng, oRange As Range
Set rng = Selection.Range

Selection.WholeStory
Set oRange = Selection.Range
    
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^p"
        .Replacement.Text = "#^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
start:
With Selection.Find
    .ClearFormatting
        .Text = "#"
        .Style = SIGNON
        .Forward = True
        .Wrap = wdFindContinue
        Selection.Find.Execute
    
    If Not Selection.Range.InRange(oRange) Then GoTo ext
    If .Found = True Then
    Selection.Delete Unit:=wdCharacter, Count:=1
    Selection.HomeKey Unit:=wdLine
    Selection.InsertBreak Type:=0
    
GoTo start
    End If
End With


ext:
    
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "#"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With


rng.Select

ending:
my_undo.EndCustomRecord

Application.ScreenUpdating = True

End Sub

[מניין]

מאקרו שמחזיר לטור אחד לפי סוג כותרת [משוכלל הרבה יותר מהמאקרו הקודם שמחזיר רק לפי מרכוז], יש אפשרות להחיל את המאקרו רק על פיסקא אחת או על כל המסמך, ומוחק כל המעברים המיותרים.
הוראות:

1. קודם כל צריך לפרוס את כל המסמך לשני טורים ולכוון את המרווחים.
2. לוחצים על הלחצן 'מחזיר לטור אחד לפי כותרת' ושואל איזה סגנון רוצים להחזיר לטור אחד.
3. שואל אם רוצים רק על פיסקא אחת או על כל המסמך, וכמובן אפשר ללחוץ על ביטול.
4. המאקרו מנקה אוטומטי את כל סוגי הכפילויות שנוצרות בגלל הפעולה.
5. אם רוצים אפשר לבטל הכל בלחיצה על קונטרול Z.
6. יש אפשרות לעשות את הפעולה גם על כמה סגנונות בכל פעם על סגנון אחר או לחזור על אותו סגנון, והמאקרו מוחקת כל הכפילויות.
7. אם רוצים להסיר ולהחזיר לשני טורים, יש לחצן נוסף 'מבטל פסקאות שעוצבו לטור אחד ומחזיר לשני טורים', יש שאלת בחירה לאחת משתי אפשרויות, או לבטל במקום אחד, או לבטל הכל בכל המסמך [במקרה שהסתבך, גם בזה יש אפשרות ביטול בלחיצה אחת קונטרול Z].

Sub מחזיר_לטור_אחד_לפי_כותרת()
    Dim Alerts As Boolean
    Dim a As Boolean
    Dim headingName As String
    Dim para As paragraph
    Dim section As section
    Dim inSelectedHeading As Boolean
    Dim userChoice As VbMsgBoxResult
    Dim deleteParagraphBreaks As VbMsgBoxResult
    On Error GoTo ErrorHandler
    Application.UndoRecord.StartCustomRecord "החזרת לטור אחד לפי כותרת"
    Alerts = Application.DisplayAlerts
    Application.DisplayAlerts = wdAlertsNone
    Application.ScreenUpdating = False
    headingName = InputBox("הזן את שם הכותרת שברצונך לשנות לטור אחד:", "בחירת כותרת")
    If headingName = "" Then
        MsgBox "לא הוזנה כותרת. הפעולה בוטלה.", vbExclamation
        Exit Sub
    End If
    userChoice = MsgBox("האם ברצונך להחיל את השינוי על כל המסמך?", vbYesNoCancel + vbQuestion, "בחירת היקף פעולה")
    If userChoice = vbCancel Then
        MsgBox "הפעולה בוטלה.", vbExclamation
        Exit Sub
    End If
    If userChoice = vbNo Then
        Selection.MoveDown Unit:=wdParagraph, count:=1
    Else
        Selection.HomeKey Unit:=wdStory
    End If
    Do
        Selection.Find.ClearFormatting
        With Selection.Find
            .Style = headingName
            .Text = "^$"
            .Forward = True
            .Wrap = wdFindStop
            .Format = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchControl = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        a = Selection.Find.Execute
        If a = True Then
            Selection.Paragraphs(1).Range.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
            Selection.MoveRight Unit:=wdCharacter, count:=1
        End If
    Loop While a = True And (userChoice = vbYes)
    Call מחיקת_מעברים_מיותרים
    Selection.HomeKey Unit:=wdStory
    MsgBox "הפעולה הושלמה! ניתן לבטל את כל השינויים באמצעות Ctrl+Z.", vbInformation
Cleanup:
    Application.DisplayAlerts = Alerts
    Application.ScreenUpdating = True
    Application.UndoRecord.EndCustomRecord
    Exit Sub
ErrorHandler:
    MsgBox "אירעה שגיאה: " & Err.Description, vbCritical
    Resume Cleanup
End Sub
Private Sub מחיקת_מעברים_מיותרים()
    Dim sectionBreakRange As Range
    Dim paraBefore As Range
    Dim paraAfter As Range
    Application.ScreenUpdating = False
    Selection.HomeKey Unit:=wdStory
    If Selection.Find.Execute(FindText:="^b", MatchWildcards:=False, Forward:=True, Wrap:=wdFindStop) = True Then
        If Selection.Start = 0 Then
            Selection.Delete
        End If
    End If
    Dim found As Boolean
    Dim specialChar As String: specialChar = ";~;"
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
        .ClearFormatting: .Text = "^b^b": .Forward = True: .Wrap = wdFindStop: .Format = False: .MatchWildcards = False
    End With
    Do While Selection.Find.Execute
        Selection.Collapse Direction:=wdCollapseEnd: Selection.TypeText Text:=specialChar
    Loop
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
        .ClearFormatting: .Text = "^b" & specialChar: .Forward = True: .Wrap = wdFindStop: .Format = False: .MatchWildcards = False
    End With
    Do While Selection.Find.Execute
        Selection.Delete
    Loop
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
        .ClearFormatting: .Text = specialChar: .Forward = True: .Wrap = wdFindStop: .Format = False: .MatchWildcards = False
    End With
    Do While Selection.Find.Execute
        Selection.Delete
    Loop
    Selection.HomeKey Unit:=wdStory
    Do While Selection.Find.Execute(FindText:="^b", MatchWildcards:=False, Forward:=True, Wrap:=wdFindStop) = True
        Set sectionBreakRange = Selection.Range
        If sectionBreakRange.Start > 0 Then
            On Error Resume Next
            Set paraBefore = sectionBreakRange.Paragraphs(1).Range.Previous(wdParagraph, 1)
            Set paraAfter = sectionBreakRange.Paragraphs(1).Range.Next(wdParagraph, 1)
            On Error GoTo 0
            If Not paraBefore Is Nothing And Not paraAfter Is Nothing Then
                If paraBefore.pageSetup.TextColumns.count = 1 And _
                   paraAfter.pageSetup.TextColumns.count = 1 Then
                    sectionBreakRange.Delete
                End If
            End If
        End If
        Selection.Start = sectionBreakRange.Start
        Selection.Collapse Direction:=wdCollapseEnd
    Loop
    Application.ScreenUpdating = True
End Sub
Sub מבטל_פסקאות_שעוצבו_לטור_אחד_ומחזיר_לשני_טורים()
    On Error GoTo ErrorHandler ' הפעלת טיפול בשגיאות
    Dim userChoice As VbMsgBoxResult
    userChoice = MsgBox("מחזיר פיסקא נוכחית לשני טורים. האם ברצונך לעשות פעולה זו על כל המסמך?", vbYesNo + vbQuestion, "מחיקת מעברי מקטע")
    If userChoice = vbYes Then
        Call מחיקת_מעברי_מקטע_בכל_המסמך
    ElseIf userChoice = vbNo Then
        Call מחיקת_מעברי_מקטע_בפסקא_נוכחית
    Else
        MsgBox "הפעולה בוטלה.", vbInformation
    End If
    Exit Sub

ErrorHandler:
    MsgBox "אירעה שגיאה: " & Err.Description, vbCritical, "שגיאה"
End Sub
Private Sub מחיקת_מעברי_מקטע_בכל_המסמך()
    On Error GoTo ErrorHandler ' הפעלת טיפול בשגיאות
    Dim para As paragraph
    Dim paraRange As Range
    Dim sectionRange As Range
    Application.UndoRecord.StartCustomRecord
    Application.ScreenUpdating = False
    Selection.HomeKey Unit:=wdStory
    For Each para In ActiveDocument.Paragraphs
        Set paraRange = para.Range
        If paraRange.pageSetup.TextColumns.count = 1 Then
            Set sectionRange = paraRange.Duplicate
            sectionRange.Collapse wdCollapseEnd
            sectionRange.MoveEnd Unit:=wdCharacter, count:=1
            
            If sectionRange.Text = Chr(12) Then
                sectionRange.Delete
                With ActiveDocument.Range(paraRange.Start - 1, paraRange.Start)
                    If .Text = Chr(12) Then
                        .Delete
                    End If
                End With
            End If
        End If
    Next para
    MsgBox "הפעולה הסתיימה בהצלחה על כל המסמך", vbInformation
    Application.ScreenUpdating = True
    Application.UndoRecord.EndCustomRecord
    Exit Sub

ErrorHandler:
    Application.ScreenUpdating = True
    Application.UndoRecord.EndCustomRecord
    MsgBox "אירעה שגיאה: " & Err.Description, vbCritical, "שגיאה"
End Sub

Private Sub מחיקת_מעברי_מקטע_בפסקא_נוכחית()
    On Error GoTo ErrorHandler ' הפעלת טיפול בשגיאות
    Dim currentPara As paragraph
    Dim paraRange As Range
    Dim sectionRange As Range
    Application.UndoRecord.StartCustomRecord
    Application.ScreenUpdating = False
    If Selection.Range.Paragraphs.count = 0 Then
        MsgBox "נא לעמוד בתוך פסקה בטור אחד.", vbExclamation
        GoTo Cleanup
    End If
    Set currentPara = Selection.Range.Paragraphs(1)
    Set paraRange = currentPara.Range
    If currentPara.Range.pageSetup.TextColumns.count <> 1 Then
        MsgBox "נא לעמוד בפסקה בטור אחד בלבד.", vbExclamation
        GoTo Cleanup
    End If
    Set sectionRange = paraRange.Duplicate
    sectionRange.Collapse wdCollapseEnd
    sectionRange.MoveEnd Unit:=wdCharacter, count:=1
    If sectionRange.Text <> Chr(12) Then
        MsgBox "נא לעמוד בפסקה האחרונה לפני מעבר לשני טורים.", vbExclamation
        GoTo Cleanup
    End If
    sectionRange.Delete
    With Selection.Find
        .ClearFormatting
        .Text = "^b"
        .Forward = False
        .Wrap = wdFindStop
        If .Execute Then Selection.Delete
    End With
    MsgBox "הפעולה הושלמה בהצלחה עבור הפסקה הנוכחית", vbInformation

Cleanup:
    Application.ScreenUpdating = True
    Application.UndoRecord.EndCustomRecord
    Exit Sub

ErrorHandler:
    Application.ScreenUpdating = True
    Application.UndoRecord.EndCustomRecord
    MsgBox "אירעה שגיאה: " & Err.Description, vbCritical, "שגיאה"
End Sub

Spoiler

שוה בדיקה

עריכה: הוכנסו שני תיקונים במאקרו, יש להוריד מחדש.
עריכה נוספת: נוסף אפשרות לשחזר את כל השינויים בלחיצה אחת על Ctrl+Z
עריכה שלישית: נוסף לחצן להסרת הפעולה, כשאין אפשרות של ביטול פעולה אחרונה, ועוד הרבה שיפורים למניעת שגיאות של כפילויות וכדו', וכן הוראות הפעלה

[מניין]

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

Sub סימון_תחילת_וסוף_עמוד()
    On Error GoTo ErrorHandler ' הפעלת טיפול בשגיאות
    Dim doc As Document
    Dim rng As Range
    Dim pageCount As Integer
    Dim i As Integer
    Dim firstWord As Range
    Dim lastWord As Range
    Dim secondLastWord As Range
    Dim lastWordEnd As Long
    Dim firstWordEnd As Long
    Dim hasPunctuation As Boolean
    
    Application.UndoRecord.StartCustomRecord
    ' קבלת המסמך הפעיל
    Set doc = ActiveDocument
    pageCount = doc.ComputeStatistics(wdStatisticPages)
    
    ' מעבר על כל עמוד במסמך
    For i = 1 To pageCount
        ' הגדרת טווח העמוד
        Set rng = doc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i)
        rng.End = doc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=i + 1).Start
        rng.End = rng.End - 1 ' להוציא את הסימן של עמוד חדש
        
        ' סימון המילה הראשונה
        Set firstWord = rng.Words(1)
        firstWordEnd = firstWord.End
        firstWord.font.Color = RGB(1, 255, 1) ' צבע ירוק בהיר
        
        ' סימון המילה האחרונה
        Set lastWord = rng.Words(rng.Words.Count)
        lastWordEnd = lastWord.End
        
        ' בדוק אם יש סימן פיסוק בסוף המילה האחרונה
        hasPunctuation = InStr(".!?," & Chr(34), Mid(lastWord.Text, Len(lastWord.Text), 1)) > 0
        
        If hasPunctuation Then
            ' אם יש סימן פיסוק, צובע את שתי המילים האחרונות
            If rng.Words.Count > 1 Then
                Set secondLastWord = rng.Words(rng.Words.Count - 1)
                secondLastWord.font.Color = RGB(255, 1, 1) ' צבע אדום בהיר
            End If
            lastWord.font.Color = RGB(255, 1, 1) ' צבע אדום בהיר
        Else
            ' אם אין סימן פיסוק, צובע רק את המילה האחרונה
            lastWord.font.Color = RGB(255, 1, 1) ' צבע אדום בהיר
        End If
    Next i
    
    MsgBox "המאקרו הסתיים בהצלחה!", vbInformation
    Application.UndoRecord.EndCustomRecord
    Exit Sub
    
ErrorHandler:
    Application.UndoRecord.EndCustomRecord
    MsgBox "אירעה שגיאה: " & Err.Description, vbCritical, "שגיאה"
End Sub
Sub חיפוש_סימונים_שלא_במקומם()
    Static currentPage As Integer
    Static errorsFound As Boolean
    Dim doc As Document
    Dim rng As Range
    Dim pageCount As Integer
    Dim i As Integer
    Dim firstWord As Range
    Dim startOfPageColor As Long

    ' צבע לבדיקה
    startOfPageColor = RGB(1, 255, 1) ' ירוק בהיר

    ' אתחול משתנים
    Set doc = ActiveDocument
    pageCount = doc.ComputeStatistics(wdStatisticPages)

    ' התחלת בדיקה מהעמוד הראשון אם זה ההפעלה הראשונה
    If currentPage = 0 Then
        currentPage = 1
        errorsFound = False ' איפוס מצב שגיאות
    End If

    ' מעבר על עמודים מהעמוד הנוכחי עד סוף המסמך
    For i = currentPage To pageCount
        ' הגדרת טווח עמוד
        Set rng = doc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, count:=i)
        rng.End = doc.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, count:=i + 1).Start - 1

        ' בדיקה אם יש מילים בעמוד
        If rng.Words.count > 0 Then
            ' קבלת המילה הראשונה בדיוק מתחילת העמוד
            Set firstWord = rng.Words(1)
            If firstWord.Information(wdActiveEndPageNumber) = i Then
                ' בדיקת צבע המילה הראשונה
                If firstWord.font.Color <> startOfPageColor Then
                    firstWord.Select
                    errorsFound = True ' נמצאה שגיאה
                    currentPage = i + 1 ' שמירת המיקום להמשך החיפוש
                    Exit Sub
                End If
            End If
        End If
    Next i

    ' אם הגענו לסוף המסמך
    If errorsFound Then
        MsgBox "החיפוש הסתיים, לא נמצאו עמודים נוספים שהשתנו", vbInformation
    Else
        MsgBox "החיפוש הסתיים ולא נמצאו עמודים שהשתנו", vbInformation
    End If

    ' איפוס המיקום והסטטוס לבדיקות חדשות
    currentPage = 0
    errorsFound = False
End Sub
Sub הסרת_הצבעים_המיוחדים()
    On Error GoTo ErrorHandler ' הפעלת טיפול בשגיאות
    Dim doc As Document
    Dim rng As Range
    Dim i As Integer
    Dim word As Range
    
    ' קבלת המסמך הפעיל
    Set doc = ActiveDocument
    
    ' מעבר על כל המילים במסמך
    For Each rng In doc.StoryRanges
        Do
            For Each word In rng.Words
                ' אם הצבע אדום בהיר או ירוק בהיר, נסיר אותו
                If word.font.Color = RGB(1, 255, 1) Or word.font.Color = RGB(255, 1, 1) Then
                    word.font.Color = wdColorAutomatic
                End If
            Next word
            Set rng = rng.NextStoryRange
        Loop While Not rng Is Nothing
    Next rng
    
    MsgBox "הצבעים הוסרו בהצלחה!", vbInformation
    Exit Sub
    
ErrorHandler:
    MsgBox "אירעה שגיאה: " & Err.Description, vbCritical, "שגיאה"
End Sub

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

[menajemmendel]

@מניין

Sub First_and_last_word_highlighting()

Dim page As Range, lastWordNumber As Integer, pageCount As Integer

    pageCount = ActiveDocument.ComputeStatistics(wdStatisticPages)
       For i = 1 To pageCount
            Selection.GoTo What:=wdGoToPage, Name:=i
            Set page = ActiveDocument.Bookmarks("\page").Range
            lastWordNumber = page.Words.Count
            page.Words(1).HighlightColorIndex = wdGreen
            page.Words(lastWordNumber).HighlightColorIndex = wdRed
        Next i
    MsgBox "המאקרו הסתיים בהצלחה!" & vbCr & vbCr & _
           "מאקרו מבית מאיר עיני חכמים-הבית לאוטומציה בוורד"
End Sub

[מניין]

פוסט זה נמחק!

[u88]

@menajemmendel למה זה?

[א. ד. ג.]

https://mitmachim.top/topic/78070/מדריך-אפלקציית-הגרלות-למחשב-באמצעות-פקודות-מאקרו-בוורד?_=1735114384700

[menajemmendel]

@u88 כתב בשיתוף | "מתעדכן" אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות.:

@menajemmendel למה זה?

זה תגובה לבקשת @מניין כאן (שביקש אם מישהו יכול לכתוב קוד שיעבוד גם בשתי טורים).

[menajemmendel]

המאקרו המהפכני שכולם חיכו לו - חובה בכל מחשב!

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

הכירו את המאקרו
מאקרו חדשני שמאפשר לספור כמה פעמים מופיעות אותיות מסוימות במסמך וורד! כן, שמעתם נכון!
הכלי הזה יאפשר לכם:
1️⃣ לגלות באילו אותיות אתם משתמשים הכי הרבה – אולי תגלו שאותיות כמו "צ" ו-"ף" זוכות להזנחה חמורה!
2️⃣ להבין לעומק את סגנון הכתיבה שלכם – מה זה אומר עליכם אם האות "ת" מופיעה פי שניים מהאות "א"? (התשובה: הרבה).
3️⃣ להרגיש מתוחכמים יותר מכל החברים שלכם, כי יש לכם מאקרו של מיספור אותיות וזה בדיוק מה שחסר להם בחיים שלהם.

למי זה מתאים?

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

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

אז למה אתם מחכים?
לחצו עכשיו על הקוד וצאו למסע שאפילו אילון מאסק עוד לא העז לחלום עליו!

Sub arraySample()
Dim otiot(1 To 22) As String
Dim otiotNumber(1 To 22) As Integer
Dim olddoc As Document
Dim newdoc As Document

otiot(1) = "א"
otiot(2) = "ב"
otiot(3) = "ג"
otiot(4) = "ד"
otiot(5) = "ה"
otiot(6) = "ו"
otiot(7) = "ז"
otiot(8) = "ח"
otiot(9) = "ט"
otiot(10) = "י"
otiot(11) = "כ"
otiot(12) = "ל"
otiot(13) = "מ"
otiot(14) = "נ"
otiot(15) = "ס"
otiot(16) = "ע"
otiot(17) = "פ"
otiot(18) = "צ"
otiot(19) = "ק"
otiot(20) = "ר"
otiot(21) = "ש"
otiot(22) = "ת"

Set olddoc = ActiveDocument
Set newdoc = Documents.Add

For i = LBound(otiot) To UBound(otiot)
    otiotNumber(i) = Len(olddoc.Range) - Len(Replace(olddoc.Range, otiot(i), ""))
    newdoc.Range.InsertAfter otiot(i) & " מופיע " & otiotNumber(i) & " מספר פעמים" & vbCr
Next i

newdoc.Activate

End Sub

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

@menajemmendel הוא עובד גם אותיות סופיות?
(אגב, מה הבעיה לספור דרך החיפוש פשוט של וורד?)

[u88]

@צדיק-וטוב-לו-0 הוא לא עובד על אותיות סופיות אבל אפשר להוסיף תראה שבשורה 2 ובשורה 3 כתוב שיש 22 מופעים של אותיות אז תוסיף אחרי שורה 28 את הקוד של האות (כמו אחת האותיות לפני) ותכתוב שם מה שאתה רוצה (רק לא לשכוח לעדכן בקוד למעלה מספר מופעים ( otiot)

[menajemmendel]

@צדיק-וטוב-לו-0 כתב בשיתוף | "מתעדכן" אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות.:

(אגב, מה הבעיה לספור דרך החיפוש פשוט של וורד?)

0

כאן אתה מקבל דו''ח, וגם כולם בבת אחת, לא צריך לעשות אחד אחד