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

**URL:** https://mobahasah.ir/t/%F0%9F%93%8A-%D9%85%D8%A7%DA%A9%D8%B1%D9%88%DB%8C-%D8%AA%D8%AD%D9%84%DB%8C%D9%84-%D9%81%D8%B1%D8%A7%D9%88%D8%A7%D9%86%DB%8C-%DA%A9%D9%84%D9%85%D8%A7%D8%AA-%D9%88-%D8%B9%D8%A8%D8%A7%D8%B1%D8%A7%D8%AA-%D9%81%D8%A7%D8%B1%D8%B3%DB%8C-%D8%AF%D8%B1-word/5888
**Category:** نکات و ترفندهای پژوهش
**Tags:** ماکرو-ورد
**Created:** [اوت 17، 2025، 8:28ب.ظ UTC](https://mobahasah.ir/t/%F0%9F%93%8A-%D9%85%D8%A7%DA%A9%D8%B1%D9%88%DB%8C-%D8%AA%D8%AD%D9%84%DB%8C%D9%84-%D9%81%D8%B1%D8%A7%D9%88%D8%A7%D9%86%DB%8C-%DA%A9%D9%84%D9%85%D8%A7%D8%AA-%D9%88-%D8%B9%D8%A8%D8%A7%D8%B1%D8%A7%D8%AA-%D9%81%D8%A7%D8%B1%D8%B3%DB%8C-%D8%AF%D8%B1-word/5888 "2025-08-17T20:28:58Z")
**Posts on this page:** 1
**Page:** 1

<div class="post-metadata">

### Author: ![Tazari](https://mobahasah.ir/letter_avatar_proxy/v4/letter/t/d9b06d/32.png) [@Tazari](https://mobahasah.ir/u/Tazari)
#### Post date: [اوت 17، 2025، 8:28ب.ظ UTC](https://mobahasah.ir/t/%F0%9F%93%8A-%D9%85%D8%A7%DA%A9%D8%B1%D9%88%DB%8C-%D8%AA%D8%AD%D9%84%DB%8C%D9%84-%D9%81%D8%B1%D8%A7%D9%88%D8%A7%D9%86%DB%8C-%DA%A9%D9%84%D9%85%D8%A7%D8%AA-%D9%88-%D8%B9%D8%A8%D8%A7%D8%B1%D8%A7%D8%AA-%D9%81%D8%A7%D8%B1%D8%B3%DB%8C-%D8%AF%D8%B1-word/5888/1 "2025-08-17T20:28:58Z")

</div>

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

> [!tip] برای مطالعه بیشتر  
> 🔗 **👈[ماکرو در ورد: خودکارسازی هوشمند کارهای تکراری!](https://mobahasah.ir/t/1093)**

* * *

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

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

* * *

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

- ⚡ **سرعت و عملکرد بالا** حتی در اسناد حجیم
- 📝 **مرتب‌سازی دقیق و پایدار** برای نمایش نتایج
- 🇮🇷 **پشتیبانی کامل از زبان فارسی** شامل نرمال‌سازی حروف، نیم‌فاصله و علائم
- 🎨 **خروجی خوانا و زیبا** با فونت فارسی مناسب
- 🧩 **امکان افزودن توقف‌واژه‌های سفارشی** توسط کاربر
- 📈 **نمایش آمار کلی** شامل تعداد عبارات یکتا و پرکاربردترین عبارت

* * *

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

کافیست کد ماکرو را در محیط **VBA Editor** (محیط برنامه‌نویسی ماکرو در Word) قرار دهید و اجرا کنید.  
📌 برای یادگیری روش اضافه‌کردن ماکرو به ورد و تنظیمات اولیه، به [آموزشی ماکروها](https://mobahasah.ir/t/1093) مراجعه کنید.

> **مشاهده کد نهایی**
>
> ```vba
> 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 – بهینه‌سازی برای موتور جستجو)
- 🗂 **استخراج کلیدواژه‌ها** برای فهرست‌نویسی یا خلاصه‌سازی
- ✍ **بررسی سبک نویسنده** و شناسایی الگوهای نوشتاری

* * *

## 📣 جمع‌بندی

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