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

Blog

מה חדש

mylogo


​עדכונים | תגובות | רעיונות
לגבי האתר, תוכנת תג, סקריפטים לתג, עימוד ספרי קודש, תוכנות מומלצות ועוד
מאת: ישורון קובי - צפת

בס"ד | ישורון קובי - צפת

מאקרו לוורד - ספירת תוים בקבצים מרובים

21/7/2019

1 Comment

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

פיתרון בצורה של מאקרו

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

כיצד המאקרו עובד

מאקרו לספירת כמות תוים בקבצים מרובים של וורד:
ראשית צריך לשים את כל הקבצים בתקייה אחת [גם קבצי doc גם docx וגם rtf]
מפעילים את המאקרו [דרך הוורד]
הוא מבקש לבחור תקייה - בוחרים את התקייה שבה הקבצים
המאקרו פותח כל אחד מהקבצים, לוקח את הנתונים וסוגר את הקובץ
ומעדכן את הנתונים בקובץ נפרד בצורה של טבלה.
זהו.
[אם מדובר בקבצים רבים כמו הדוגמא שהבאתי אז צריך קצת סבלנות... איזה 10 דקות].
countmacro
כך נראית התוצאה פחות או יותר
הקוד של המאקרו נמצא בסמוך...
​Sub CountCharsForMultipleWordFiles()
'
' CountCharsForMultipleWordFiles
' ספירת כמות תוים במסמכים מרובים כולל הערות שוליים והערות סיום.
'
Dim fd As FileDialog
Dim DocSource As Document
Dim doctarget As Document

Dim tblTarget As Table
Dim tblrow As Row

Dim bNotRtfDone As Boolean
Dim bHasFootNotes As Boolean
Dim bHasEndNotes As Boolean

Dim lDocumntChars As Long
Dim lTotalCount As Long

Dim lFootnoteChars As Long
Dim lFootnoteCount As Long
Dim lEndnoteChars As Long
Dim lEndnoteCount As Long

Dim sStr As String

Set fd = Application.FileDialog(msoFileDialogFolderPicker)

With fd
    .Title = "בחר את התקיה שמכילה את הקבצים"
    If .Show = -1 Then
        strFolder = .SelectedItems(1) & "\"
    Else
        MsgBox "לא נבחרה תקיה.", vbMsgBoxRtlReading
        Exit Sub
    End If
End With

strFile = Dir$(strFolder & "*.doc*")

If strFile = "" Then
    bNotRtfDone = True
    strFile = Dir$(strFolder & "*.rtf")
    If strFile = "" Then
        MsgBox "התקיה לא מכילה קבצי וורד.", vbMsgBoxRtlReading
        Exit Sub
    End If
End If

Set doctarget = Documents.Add
Set tblTarget = doctarget.Tables.Add(doctarget.Range, 1, 3)

With tblTarget
    With .Range.Font
        .SizeBi = 9
        .Size = 8
    End With
    With .Cell(1, 1).Range
        .Text = "שם הקובץ"
        .Font.ColorIndexBi = wdBlue
        .Font.BoldBi = True
    End With
    With .Cell(1, 2).Range
        .Text = "הקובץ מכיל הערות שוליים/סיום"
        .Font.ColorIndexBi = wdBlue
        .Font.BoldBi = False
        .Font.SizeBi = 8
    End With
    With .Cell(1, 3).Range
        .Text = "כמות תוים עם רווחים"
        .Font.ColorIndexBi = wdBlue
        .Font.BoldBi = True
    End With
End With

re:
While strFile <> ""
    bHasFootNotes = False
    bHasEndNotes = False
    Set DocSource = Documents.Open(strFolder & strFile)
    lFootnoteCount = DocSource.Footnotes.Count
    lEndnoteCount = DocSource.Endnotes.Count
    lDocumntChars = DocSource.Characters.Count - DocSource.Paragraphs.Count - lEndnoteCount
    Set objRange = DocSource.StoryRanges
    
    If lFootnoteCount > 0 Then
    bHasFootNotes = True
     For Each objRange In DocSource.StoryRanges
       If objRange.StoryType = wdFootnotesStory Then
         lFootnoteChars = objRange.Characters.Count - lFootnoteCount
         lDocumntChars = lDocumntChars + lFootnoteChars
       End If
     Next objRange
    End If
    
    If lEndnoteCount > 0 Then
    bHasEndNotes = True
     For Each objRange In DocSource.StoryRanges
       If objRange.StoryType = wdEndnotesStory Then
         lEndnoteChars = objRange.Characters.Count - lEndnoteCount
         lDocumntChars = lDocumntChars + lEndnoteChars
       End If
     Next objRange
    End If

    Set tblrow = tblTarget.Rows.Add
    With tblrow.Range.Font
        .BoldBi = False
        .ColorIndexBi = wdAuto
    End With
    
    With tblrow
        .Cells(1).Range.Text = DocSource.name
        With .Cells(2).Range
            .Font.ColorIndexBi = wdGray50
            If (bHasFootNotes + bHasEndNotes) Then
                If bHasFootNotes Then
                    If bHasEndNotes Then
                        sStr = "הערות שוליים + סיום"
                    Else
                        sStr = "הערות שוליים"
                    End If
                Else
                    sStr = "הערות סיום"
                End If
            Else
                sStr = "---"
            End If
            .Text = sStr
        End With
        With .Cells(3).Range
            .Font.ColorIndexBi = wdGray50
            .Text = lDocumntChars
        End With
    End With
    
    lTotalCount = lTotalCount + lDocumntChars
    DocSource.Close wdDoNotSaveChanges

    strFile = Dir$()
Wend

If Not bNotRtfDone Then
    bNotRtfDone = True
    strFile = Dir$(strFolder & "*.rtf")
    GoTo re
End If

Set tblrow = tblTarget.Rows.Add

With tblrow
    .Range.Font.BoldBi = True
    .Range.Font.ColorIndexBi = wdRed
    .Cells(1).Range.Text = "סך הכל"
    .Cells(3).Range.Text = lTotalCount
End With

doctarget.Activate

End Sub
1 Comment
annisa luthfiatu azzahra link
28/11/2024 04:48:53

מאוד מעניין לקרוא על מאקרו לספירת תווים בוורד. זה נשמע שימושי במיוחד לעורכים ולכותבים. האם יש אפשרות להחיל את זה גם על קבצים בפורמטים אחרים? אשמח ללמוד עוד על הנושא, ומצאתי מדריך מעניין נוסף כאן: <a href="https://jakarta.telkomuniversity.ac.id/en/multilingual-wpml-plugin-usage-guide/">Click here</a>

Reply



Leave a Reply.

    מחבר

    ישורון קובי - צפת

    mylogo

    ארכיון

    May 2024
    November 2023
    June 2023
    May 2022
    April 2022
    March 2022
    December 2021
    November 2021
    October 2021
    August 2021
    June 2021
    March 2021
    February 2021
    January 2021
    November 2020
    October 2020
    September 2020
    July 2020
    May 2020
    March 2020
    February 2020
    January 2020
    December 2019
    July 2019
    June 2019
    May 2019
    April 2019
    March 2019
    February 2019
    January 2019
    December 2018
    November 2018
    September 2018
    July 2018
    April 2018
    March 2018
    February 2018
    October 2017
    September 2017
    June 2017
    May 2017
    April 2017

    קטגוריות

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

    RSS Feed

ישורון קובי | עימוד ספרים | עיה"ק צפת תובב"א
באתר של ישורון קובי search by freefind advanced
  • עמוד הבית
    • עימוד רגיל
    • שני טקסטים
    • רב טקסט
    • גופן סימנים לתג
  • תוסף רב טקסט
    • הדרכה לתוסף
    • רישום והזמנה
    • שאלות ותשובות
  • סקריפטים לתג
  • הורדות
  • סרטוני הדרכה
    • קורסים
  • שימושי לוורד
    • הדרכה ועדכונים
  • הבלוג של ישורון
  • צור קשר