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

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

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

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

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

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

הקוד של המאקרו נמצא בסמוך...

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

שאלות, הערות או הארות? אשמח לשמוע - כתבו לי דרך עמוד צור קשר.