📊 ماکروی تحلیل فراوانی کلمات و عبارات فارسی در Word

[Tazari (محمد طزری)]

اگر با ماکروها آشنا نیستید یا می‌خواهید روش ضبط و اجرای آن‌ها را یاد بگیرید، پیشنهاد می‌کنم پیش از ادامه، تاپیک زیر را مطالعه کنید:

[!tip] برای مطالعه بیشتر
ماکرو در ورد: خودکارسازی هوشمند کارهای تکراری!

---

هدف و کارکرد این ماکرو

این ماکرو یک ابزار قدرتمند برای تحلیل فراوانی واژگان و عبارات در اسناد فارسی Word (مایکروسافت ورد) است و امکانات زیر را در اختیار شما قرار می‌دهد:
شمارش کلمات یا گروهی از کلمات (عبارات چندواژه‌ای)
حذف توقف‌واژه‌ها (Stop Words – کلماتی که در متن اهمیت معنایی کمی دارند)
مدیریت نیم‌فاصله‌ها با سه حالت دلخواه
انتخاب نگه‌داشتن یا حذف اعداد
مرتب‌سازی نتایج بر اساس بیشترین فراوانی یا حروف الفبا
تعیین حداقل تعداد تکرار برای نمایش در خروجی
امکان تحلیل فقط متن انتخاب‌شده یا کل سند

---

ویژگی‌های برجسته

• سرعت و عملکرد بالا حتی در اسناد حجیم
• مرتب‌سازی دقیق و پایدار برای نمایش نتایج
• پشتیبانی کامل از زبان فارسی شامل نرمال‌سازی حروف، نیم‌فاصله و علائم
• خروجی خوانا و زیبا با فونت فارسی مناسب
• امکان افزودن توقف‌واژه‌های سفارشی توسط کاربر
• نمایش آمار کلی شامل تعداد عبارات یکتا و پرکاربردترین عبارت

---

دریافت و استفاده

کافیست کد ماکرو را در محیط VBA Editor (محیط برنامه‌نویسی ماکرو در Word) قرار دهید و اجرا کنید.
برای یادگیری روش اضافه‌کردن ماکرو به ورد و تنظیمات اولیه، به آموزشی ماکروها مراجعه کنید.

مشاهده کد نهایی

 Option Explicit

' =========================
' Persian N-gram Frequency Analyzer (Final, optimized, dependency-free)
' =========================

Public Sub RunPersianWordFrequencyAnalyzer()
    Dim doc As Document
    Dim srcText As String
    Dim wordDict As Object, stopWordDict As Object
    
    Dim ans As String
    Dim nGramSize As Long
    Dim sortByFreq As Boolean
    Dim zwnjOption As Long
    Dim exStart As Boolean, exEnd As Boolean, exAny As Boolean
    Dim keepNumbers As Boolean
    Dim minFreq As Long
    Dim processSelection As Boolean
    Dim extraStop As String
    
    ' --- دريافت تنظيمات ---
    ans = MsgBox("فقط متن انتخاب‌شده پردازش شود؟", vbYesNo + vbQuestion, "محدوده پردازش")
    processSelection = (ans = vbYes)
    
    ans = InputBox("تعداد کلمات در هر عبارت (1=تک‌واژه، حداکثر 10):", "اندازه N-gram", "1")
    If StrPtr(ans) = 0 Then Exit Sub
    If IsNumeric(ans) And Val(ans) > 0 Then
        nGramSize = CLng(ans): If nGramSize > 10 Then nGramSize = 10
    Else
        MsgBox "ورودي نامعتبر، مقدار پيش‌فرض 1 انتخاب شد.", vbInformation
        nGramSize = 1
    End If
    
    ans = InputBox("مرتب‌سازي بر اساس 'FREQ' (فراواني) يا 'WORD' (عبارت)؟", "نحوه مرتب‌سازي", "FREQ")
    If StrPtr(ans) = 0 Then Exit Sub
    ans = UCase$(Trim$(ans))
    If ans <> "WORD" And ans <> "FREQ" Then
        MsgBox "ورودي نامعتبر، حالت 'FREQ' انتخاب شد.", vbInformation
        sortByFreq = True
    Else
        sortByFreq = (ans = "FREQ")
    End If
    
    ans = InputBox("نحوه برخورد با نيم‌فاصله:" & vbCrLf & _
                   "0 = جايگزيني با فاصله" & vbCrLf & _
                   "1 = حذف کامل" & vbCrLf & _
                   "2 = حفظ نيم‌فاصله", "تنظيمات نيم‌فاصله", "0")
    If StrPtr(ans) = 0 Then Exit Sub
    If IsNumeric(ans) And CInt(ans) >= 0 And CInt(ans) <= 2 Then
        zwnjOption = CInt(ans)
    Else
        zwnjOption = 0
    End If
    
    ans = MsgBox("اعداد در تحليل حفظ شوند؟" & vbCrLf & "بله = حفظ | خير = حذف", vbYesNo + vbQuestion, "اعداد")
    keepNumbers = (ans = vbYes)
    
    ans = InputBox("حداقل فراواني براي نمايش در خروجي:", "آستانه نمايش", "1")
    If StrPtr(ans) = 0 Then Exit Sub
    If IsNumeric(ans) And CLng(ans) >= 1 Then
        minFreq = CLng(ans)
    Else
        minFreq = 1
    End If
    
    exStart = (MsgBox("عباراتي که با توقف‌واژه شروع مي‌شوند حذف شوند؟", vbYesNo + vbQuestion) = vbYes)
    exEnd = (MsgBox("عباراتي که با توقف‌واژه تمام مي‌شوند حذف شوند؟", vbYesNo + vbQuestion) = vbYes)
    exAny = (MsgBox("عباراتي که شامل توقف‌واژه هستند حذف شوند؟", vbYesNo + vbQuestion) = vbYes)
    
    extraStop = InputBox("توقف‌واژه‌هاي اضافي (جداشده با ويرگول)، اختياري:", "توقف‌واژه‌هاي سفارشي", "")
    If StrPtr(extraStop) = 0 Then Exit Sub
    
    ' --- پردازش ---
    Application.ScreenUpdating = False
    On Error GoTo ErrorHandler
    
    Set doc = ActiveDocument
    If processSelection And Selection Is Nothing Then processSelection = False
    
    If processSelection And Selection.Range.Characters.Count > 0 Then
        srcText = Selection.Range.Text
    Else
        srcText = doc.Content.Text
    End If
    
    Set wordDict = CreateObject("Scripting.Dictionary")
    Set stopWordDict = CreateObject("Scripting.Dictionary")
    
    BuildStopWords stopWordDict, extraStop
    
    Dim cleanedText As String
    cleanedText = CleanText(srcText, zwnjOption, keepNumbers)
    If Len(cleanedText) = 0 Then
        Documents.Add.Content.Text = "هيچ عبارتي يافت نشد."
        GoTo CleanExit
    End If
    
    ExtractNGramsFromText cleanedText, wordDict, stopWordDict, nGramSize, exStart, exEnd, exAny
    
    DisplayResults wordDict, sortByFreq, minFreq
    
    MsgBox "تحليل با موفقيت انجام شد." & vbCrLf & _
           "تعداد عبارات يکتا: " & CStr(wordDict.Count), vbInformation, "پايان کار"
    
CleanExit:
    Application.ScreenUpdating = True
    Set doc = Nothing
    Set wordDict = Nothing
    Set stopWordDict = Nothing
    Exit Sub
    
ErrorHandler:
    MsgBox "يک خطاي پيش‌بيني‌نشده رخ داد:" & vbCrLf & Err.Description, vbCritical, "خطا"
    Resume CleanExit
End Sub

' --- توقف‌واژه‌ها (پيش‌فرض + سفارشي کاربر) ---
Private Sub BuildStopWords(ByRef stopDict As Object, ByVal extraStopCSV As String)
    Dim baseList As String
    baseList = "و,در,به,از,که,اين,آن,براي,با,است,را,مي,تا,اما,اگر,هم,يا,يک,شود,کرد,شد,نيز,بر,هر,چون"
    
    Dim item As Variant
    For Each item In Split(baseList, ",")
        item = LCase$(Trim$(CStr(item)))
        If Len(item) > 0 Then
            If Not stopDict.Exists(item) Then stopDict.Add item, True
        End If
    Next item
    
    If Len(Trim$(extraStopCSV)) > 0 Then
        Dim ex As Variant
    extraStopCSV = Replace(extraStopCSV, "،", ",")
    extraStopCSV = Replace(extraStopCSV, "*", ",")
    extraStopCSV = Replace(extraStopCSV, "#", ",")
        For Each ex In Split(extraStopCSV, ",")
            ex = LCase$(Trim$(CStr(ex)))
            If Len(ex) > 0 Then
                If Not stopDict.Exists(ex) Then stopDict.Add ex, True
            End If
        Next ex
    End If
End Sub

' --- پاکسازي متن و نرمال‌سازي ---
' --- پاکسازي متن و نرمال‌سازي ---
Private Function CleanText(ByVal txt As String, ByVal zwnjOption As Long, ByVal keepNumbers As Boolean) As String
    Dim re As Object: Set re = CreateObject("VBScript.RegExp")
    re.Global = True
    
    ' حروف کوچک
    txt = LCase$(txt)
    
    ' نرمال‌سازي حروف فارسي/عربي
    txt = Replace(txt, ChrW(1603), ChrW(1705)) ' ك -> ک
    txt = Replace(txt, ChrW(1610), ChrW(1740)) ' ي -> ي
    txt = Replace(txt, ChrW(1570), ChrW(1575)) ' آ -> ا
    txt = Replace(txt, ChrW(1571), ChrW(1575)) ' أ -> ا
    txt = Replace(txt, ChrW(1573), ChrW(1575)) ' إ -> ا
    txt = Replace(txt, ChrW(1577), ChrW(1607)) ' ة -> ه
    
    ' نيم‌فاصله
    Select Case zwnjOption
        Case 0: txt = Replace(txt, ChrW(8204), " ")
        Case 1: txt = Replace(txt, ChrW(8204), "")
        Case 2: ' حفظ
    End Select
    
    ' NBSP به فاصله
    txt = Replace(txt, ChrW(160), " ")
    
    ' حذف علائم اعراب و کنترل
    re.Pattern = "[\u064B-\u065F\u0670\u0640\u200D\u200E\u200F]"
    txt = re.Replace(txt, "")
    
    ' حذف اعداد و نشانه‌گذاري (در صورت نياز)
    If keepNumbers Then
        ' فقط علائم نگارشي حذف شوند
        re.Pattern = "[\[\]{}<>\./\\\|\+\=\*\&\^%$#@~`_\-:;!,\?""'،؛؟«»–—]"
    Else
        ' اعداد و علائم نگارشي حذف شوند
        re.Pattern = "[0-9\[\]{}<>\./\\\|\+\=\*\&\^%$#@~`_\-:;!,\?""'،؛؟«»–—]"
    End If
    
    txt = re.Replace(txt, " ")
    
    ' يکنواخت‌سازي فاصله‌ها
    re.Pattern = "\s+"
    txt = re.Replace(txt, " ")
    
    CleanText = Trim$(txt)
End Function

' --- استخراج N-gram از متن پاکسازي‌شده ---
Private Sub ExtractNGramsFromText(ByVal cleanedText As String, ByRef dict As Object, ByRef stopDict As Object, _
                                  ByVal n As Long, ByVal exStart As Boolean, ByVal exEnd As Boolean, ByVal exAny As Boolean)
    If Len(cleanedText) = 0 Then Exit Sub
    
    Dim wordsArr() As String
    wordsArr = Split(cleanedText, " ")
    If UBound(wordsArr) + 1 < n Then Exit Sub
    
    Dim i As Long, j As Long
    Dim gram As String
    
    For i = 0 To UBound(wordsArr) - (n - 1)
        ' ساختن n-gram
        gram = wordsArr(i)
        For j = 1 To n - 1
            gram = gram & " " & wordsArr(i + j)
        Next j
        
        If Not ShouldSkipGram(gram, stopDict, n, exStart, exEnd, exAny) Then
            If dict.Exists(gram) Then
                dict(gram) = dict(gram) + 1
            Else
                dict.Add gram, 1
            End If
        End If
    Next i
End Sub

' --- قوانين حذف بر اساس توقف‌واژه ---
Private Function ShouldSkipGram(ByVal gram As String, ByRef stopDict As Object, _
                                ByVal n As Long, ByVal exStart As Boolean, ByVal exEnd As Boolean, ByVal exAny As Boolean) As Boolean
    gram = LCase$(Trim$(gram))
    
    If n = 1 Then
        ShouldSkipGram = stopDict.Exists(gram)
        Exit Function
    End If
    
    Dim parts() As String
    parts = Split(gram, " ")
    
    If exStart And stopDict.Exists(parts(0)) Then
        ShouldSkipGram = True: Exit Function
    End If
    If exEnd And stopDict.Exists(parts(UBound(parts))) Then
        ShouldSkipGram = True: Exit Function
    End If
    
    If exAny Then
        Dim k As Long
        For k = 0 To UBound(parts)
            If stopDict.Exists(parts(k)) Then
                ShouldSkipGram = True: Exit Function
            End If
        Next k
    End If
End Function

' --- نمايش نتايج با مرتب‌سازي پايدار و بدون وابستگي ---
Private Sub DisplayResults(ByRef dict As Object, ByVal sortByFreq As Boolean, ByVal minFreq As Long)
    If dict Is Nothing Or dict.Count = 0 Then
        Documents.Add.Content.Text = "هيچ عبارتي يافت نشد."
        Exit Sub
    End If
    
    ' تبديل به آرايه‌ها
    Dim cnt As Long: cnt = dict.Count
    Dim keys() As String, vals() As Long
    ReDim keys(0 To cnt - 1)
    ReDim vals(0 To cnt - 1)
    
    Dim i As Long
    For i = 0 To cnt - 1
        keys(i) = dict.keys()(i)
        vals(i) = dict.Items()(i)
    Next i
    
    ' محاسبه پرتکرارترين (ساده)
    Dim maxKey As String, maxVal As Long
    maxVal = -1
    maxKey = ""

    For i = 0 To cnt - 1
        If vals(i) > maxVal Then
            maxVal = vals(i)
            maxKey = keys(i)
        End If
    Next i
    
    ' اطمينان از مقداردهي
    If Len(maxKey) = 0 And cnt > 0 Then
        maxKey = keys(0)
        maxVal = vals(0)
    End If
    
    ' مرتب‌سازي
    QuickSortPairs keys, vals, 0, UBound(keys), sortByFreq
    
    ' ساخت خروجي
    Dim header As String
    header = "آمار کلي:" & vbCrLf & _
             "تعداد عبارات يکتا: " & CStr(cnt) & vbCrLf & _
             "پرتکرارترين عبارت: " & maxKey & " (" & CStr(maxVal) & " بار)" & vbCrLf & _
             String$(40, "-") & vbCrLf & "تعداد" & vbTab & "عبارت" & vbCrLf & String$(40, "-")
    
    ' ايجاد خطوط خروجي با فيلتر حداقل فراواني
    Dim lines() As String
    ReDim lines(0 To cnt) ' حداکثر؛ بعداً تعداد واقعي را محاسبه مي‌کنيم
    
    Dim outIndex As Long: outIndex = -1
    For i = 0 To cnt - 1
        If vals(i) >= minFreq Then
            outIndex = outIndex + 1
            lines(outIndex) = ToPersianDigits(CStr(vals(i))) & vbTab & keys(i)
        End If
    Next i
    
    Dim body As String
    If outIndex = -1 Then
        body = vbCrLf & "(هيچ عبارتي با آستانه فراواني تعيين‌شده يافت نشد.)"
    Else
        ReDim Preserve lines(0 To outIndex)
        body = vbCrLf & Join(lines, vbCrLf)
    End If
    
    ' درج در سند جديد
    Dim outputDoc As Document
    Set outputDoc = Documents.Add
    With outputDoc.Content
        .Text = header & body
        On Error Resume Next
        .Font.Name = "B Nazanin"
        .Font.Size = 12
        On Error GoTo 0
    End With
End Sub
' --- QuickSort روي جفت‌هاي (کليد/مقدار) با قاعده مقايسه ---
Private Sub QuickSortPairs(ByRef keys() As String, ByRef vals() As Long, _
                           ByVal first As Long, ByVal last As Long, ByVal byFreq As Boolean)
    Dim i As Long, j As Long
    Dim pivotK As String, pivotV As Long
    Dim mid As Long
    Dim tmpK As String, tmpV As Long
    
    i = first: j = last
    mid = (first + last) \ 2
    pivotK = keys(mid): pivotV = vals(mid)
    
    Do While i <= j
        Do While ComparePair(keys(i), vals(i), pivotK, pivotV, byFreq) < 0
            i = i + 1
        Loop
        Do While ComparePair(keys(j), vals(j), pivotK, pivotV, byFreq) > 0
            j = j - 1
        Loop
        If i <= j Then
            tmpK = keys(i): keys(i) = keys(j): keys(j) = tmpK
            tmpV = vals(i): vals(i) = vals(j): vals(j) = tmpV
            i = i + 1: j = j - 1
        End If
    Loop
    
    If first < j Then QuickSortPairs keys, vals, first, j, byFreq
    If i < last Then QuickSortPairs keys, vals, i, last, byFreq
End Sub

' مقايسه: اگر byFreq=True، مرتب‌سازي بر اساس فراواني نزولي و در تساوي بر اساس عبارت صعودي
' اگر byFreq=False، صرفاً بر اساس عبارت صعودي (در تساوي، فراواني نزولي براي پايداري ظاهري)
Private Function ComparePair(ByVal aK As String, ByVal aV As Long, _
                             ByVal bK As String, ByVal bV As Long, ByVal byFreq As Boolean) As Long
    If byFreq Then
        If aV > bV Then
            ComparePair = -1: Exit Function
        ElseIf aV < bV Then
            ComparePair = 1: Exit Function
        Else
            ComparePair = StrComp(aK, bK, vbTextCompare)
            Exit Function
        End If
    Else
        Dim c As Long
        c = StrComp(aK, bK, vbTextCompare)
        If c <> 0 Then
            ComparePair = c: Exit Function
        ElseIf aV > bV Then
            ComparePair = -1: Exit Function
        ElseIf aV < bV Then
            ComparePair = 1: Exit Function
        Else
            ComparePair = 0: Exit Function
        End If
    End If
End Function

' --- تبديل ارقام لاتين به فارسي براي نمايش ---
Private Function ToPersianDigits(ByVal s As String) As String
    Dim i As Long, ch As Integer
    Dim result As String: result = s
    For i = 0 To 9
        result = Replace(result, CStr(i), ChrW(&H6F0 + i))
    Next i
    ToPersianDigits = result
End Function

' پايان

---

نکات استفاده

1. فعال بودن ماکروها – پیش از اجرا، مطمئن شوید تنظیمات امنیتی ورد اجازه اجرای ماکرو را می‌دهد.
2. انتخاب محدوده متن – اگر گزینه‌ی «پردازش متن انتخاب‌شده» را انتخاب کنید، فقط بخشی از سند که هایلایت کرده‌اید بررسی می‌شود، در غیر این صورت کل متن سند پردازش خواهد شد.
3. افزودن توقف‌واژه‌های دلخواه – هنگام وارد کردن فهرست توقف‌واژه‌ها، بین هر کلمه و کلمه‌ی بعدی یکی از این چهار علامت را قرار دهید: ویرگول فارسی «،» یا ویرگول انگلیسی «,» یا ستاره «*» یا علامت «#».
4. نمایش نتایج – خروجی ماکرو همیشه در یک سند جدید نمایش داده می‌شود تا متن اصلی شما دست‌نخورده باقی بماند.

---

کاربردهای پیشنهادی

• پژوهش و تحلیل متون علمی
• بهینه‌سازی متن برای سئو (SEO – بهینه‌سازی برای موتور جستجو)
• استخراج کلیدواژه‌ها برای فهرست‌نویسی یا خلاصه‌سازی
• بررسی سبک نویسنده و شناسایی الگوهای نوشتاری

---

جمع‌بندی

این ماکرو حاصل چندین مرحله بازطراحی و بهینه‌سازی است و می‌تواند ابزاری کاربردی برای پژوهشگران، ویراستاران، ناشران و علاقه‌مندان به زبان فارسی باشد.