ترتيب أرقام محددة بينها فاصلة أو شرطة أو غيرهما:

[أبو عاصم المصري]

من الأمور التي نحتاجها أحيانا أن نرتب مجموعة أرقام على غرار (45، 30، 25، 15، 10، 5، 40، 20، 35، 50)

والترتيب اليدوي يستغرق وقتا، كما أنه لم يسلم من الخطأ.

وهذا الماكرو يقوم بعملية ترتيب أرقام محددة بمجرد تحديد هذه الأرقام وتشغيل الماكرو:

' ماكرو لترتيب أرقام محددة
'بحيث تظلل مجموعة أرقام بينها فاصلة (،) وتشغل الماكرو ليقوم بترتيب هذه الأرقام من الأصغر إلى الأكبر
'
    
    On Error Resume Next
    Dim objSelection As Range
    Dim strText As String
    Dim i As Long
    Dim arabicChars As String
    Dim StrData As String, j As Long, DataArray()
    Dim aa As String '''''''''''
    Dim searchTerm1 As String
    Dim searchTerm2 As String
    Dim searchTerm3 As String
    Dim textToSearch As String
    Dim position1 As Integer
    Dim position2 As Integer
   
   If Len(Selection.Text) = 1 Then
   MsgBox "من فضلك ظلل الأرقام التي تريد ترتيبها"
   Beep
   Exit Sub
   Else
   End If
  
    '''''''''' إذا كان يوجد في النص المحدد هذه العلامات فأوقف الماكرو
    searchTerm1 = "-"
    searchTerm2 = "،"
    searchTerm3 = ":"
    textToSearch = Selection.Text
    
    position1 = InStr(1, textToSearch, searchTerm1)
    position2 = InStr(1, textToSearch, searchTerm2)
    position3 = InStr(1, textToSearch, searchTerm3)
    If position1 > 0 And position2 > 0 Then
    Beep
    MsgBox "يوجد أكثر من فاصل بين الأرقام المحددة"
    Exit Sub
    Else
    End If
    ''''''''''
    ''''''''''''''''''''''' لقفل الماكرو عند الضغط على زر escape
   aa = InputBox(Prompt:="حدد الفاصل بين الأرقام (، أو -) أو غيرهما", _
          title:="ترتيب أرقـــــام", Default:="، ")
           If aa = "" Or _
           aa = vbNullString Then
           Beep
           Exit Sub
           End If
   ''''''''''''
   ss = Selection.Text
   StrData = ss
   
   If InStr(Selection, aa) <> 0 Then  ''''''''''''
   Beep
   Else: MsgBox "لا يوجد الفاصل الذي حددته بين الأرقام" '''' إذا لم يوجد فاصلة ضمن النص المحدد
   Exit Sub
   End If

    arabicChars = "أبتثجحخدذرزسشصضطظعغفقكلمنهويةئؤإآ"
    Set objSelection = Selection.Range
    strText = objSelection.Text

    For i = 1 To Len(arabicChars)
        If InStr(1, strText, Mid$(arabicChars, i, 1), vbBinaryCompare) > 0 Then
            MsgBox "الجملة المحددة تحتوي على حروف هجائية"
            Exit Sub
        End If
    Next i

j = UBound(Split(StrData, aa)): ReDim DataArray(j)
For i = 0 To j
DataArray(i) = Split(StrData, aa)(i)
Next
WordBasic.sortArray DataArray()
MsgBox Join(DataArray(), aa)
Selection.TypeText Text:=Join(DataArray(), aa)
Beep
End Sub

[تومي محمد]

شكرا

[مصطفى شاهين]

شكرا

معلومة قيِّمة فعلاً

الله يعطيكم ألف عافية

[تومي محمد]

جيد

[قلم.رصاص]

الكود سوف يعمل لكنه يعتمد على WordBasic (قديم) يقوم بترتيب نصي لا رقمي

 

سوف أشارك معكم: ماكرو متقدم لفرز الأرقام داخل Microsoft Word بدون استخدام WordBasic مع دعم كامل للأعداد العشرية والفواصل المختلفة

• دعم الأعداد العشرية
• كشف الفاصل تلقائيا (، , ; | - :)
• إمكانية إدخال الفاصل يدويا
• خيار ترتيب تصاعدي/تنازلي
• التحقق من صحة البيانات (رفض الحروف)
• استبدال النص مباشرة داخل التحديد

الكود

Option Explicit

Private Const MODULE_NAME           As String = "SortSelectionModule"
Private Const PROC_MAIN             As String = "SortSelectedNumbersInWord"

Private Const ERR_NO_SELECTION      As Long = vbObjectError + 1001
Private Const ERR_EMPTY_TOKEN       As Long = vbObjectError + 1002
Private Const ERR_NON_NUMERIC       As Long = vbObjectError + 1003
Private Const ERR_NO_VALID_TOKENS   As Long = vbObjectError + 1004
Private Const ERR_USER_CANCEL       As Long = vbObjectError + 1005

Private Const DEFAULT_DELIMITER     As String = "،"

Public Sub SortSelectedNumbersInWord()
    Const PROC_NAME As String = PROC_MAIN
    On Error GoTo ErrorHandler

    Dim selectedText As String
    selectedText = Trim$(Selection.Text)

    Debug.Print String(50, "=")
    Debug.Print "INPUT TEXT = [" & selectedText & "]"

    If Len(selectedText) <= 1 Then
        Err.Raise ERR_NO_SELECTION, PROC_NAME, "يرجى تحديد قائمة أرقام مفصولة بمحدد."
    End If

    Dim autoDelim As String
    Dim delimiter As String

    autoDelim = DetectDelimiter(selectedText)
    autoDelim = Trim$(autoDelim)

    Dim respDelim As VbMsgBoxResult

    respDelim = MsgBox( _
        "تم اكتشاف الفاصل: [" & autoDelim & "]" & vbCrLf & vbCrLf & _
        "هل تريد استخدامه؟" & vbCrLf & _
        "Yes = استخدام التلقائي" & vbCrLf & _
        "No = إدخال فاصل يدوي", _
        vbYesNoCancel + vbQuestion, "اختيار الفاصل")

    If respDelim = vbCancel Then
        Err.Raise ERR_USER_CANCEL, PROC_NAME, "تم الإلغاء."
    End If

    If respDelim = vbYes And Len(autoDelim) > 0 Then
        delimiter = autoDelim
    Else
        delimiter = InputBox( _
            "أدخل الفاصل بين الأرقام (مثل: ، أو , أو ; أو | أو -):", _
            "إدخال الفاصل يدويًا", DEFAULT_DELIMITER)

        If Len(Trim$(delimiter)) = 0 Then
            Err.Raise ERR_USER_CANCEL, PROC_NAME, "تم الإلغاء."
        End If
    End If

    Dim cleanedText As String
    cleanedText = Replace(selectedText, " " & delimiter & " ", delimiter)
    cleanedText = Replace(cleanedText, delimiter & " ", delimiter)
    cleanedText = Replace(cleanedText, " " & delimiter, delimiter)

    Debug.Print "CLEANED TEXT = [" & cleanedText & "]"

    Dim resp As VbMsgBoxResult
    resp = MsgBox("Yes = تصاعدي / No = تنازلي", vbYesNoCancel)

    If resp = vbCancel Then Err.Raise ERR_USER_CANCEL, PROC_NAME, "تم الإلغاء."

    Dim isDesc As Boolean
    isDesc = (resp = vbNo)

    Dim rawTokens() As String
    rawTokens = Split(cleanedText, delimiter)

    Debug.Print "ELEMENTS COUNT = " & (UBound(rawTokens) - LBound(rawTokens) + 1)

    Dim values() As Double
    ReDim values(0 To UBound(rawTokens))

    Dim i As Long, validCount As Long
    Dim t As String

    validCount = 0

    For i = LBound(rawTokens) To UBound(rawTokens)

        t = Trim$(rawTokens(i))
        Debug.Print "TOKEN[" & i & "] = [" & t & "]"

        If Len(t) > 0 Then

            If Not IsNumeric(t) Then
                Err.Raise ERR_NON_NUMERIC, PROC_NAME, "قيمة غير رقمية: [" & t & "]"
            End If

            values(validCount) = CDbl(t)
            validCount = validCount + 1
        End If

    Next i

    If validCount = 0 Then
        Err.Raise ERR_NO_VALID_TOKENS, PROC_NAME, "لا توجد أرقام صالحة."
    End If

    ReDim Preserve values(0 To validCount - 1)

    If validCount > 1 Then
        QuickSort values, 0, validCount - 1, isDesc
    End If

    Dim output() As String
    ReDim output(0 To validCount - 1)

    For i = 0 To validCount - 1
        output(i) = Trim$(CStr(values(i)))
    Next i

    Dim result As String
    Dim sep As String
    sep = delimiter & " "

    Dim k As Long
    result = output(0)

    For k = 1 To validCount - 1
        result = result & sep & output(k)
    Next k

    With Selection
        .Delete
        .TypeText result
    End With

    Debug.Print "SORTED TEXT = [" & result & "]"
    Debug.Print "SORT COMPLETED SUCCESSFULLY"
    Debug.Print String(50, "=")

    Exit Sub

ErrorHandler:

    Debug.Print String(50, "-")
    Debug.Print "ERROR NUMBER : " & Err.Number
    Debug.Print "ERROR DESC   : " & Err.Description
    Debug.Print "PROCEDURE    : " & MODULE_NAME & "." & PROC_NAME
    Debug.Print String(50, "-")

    MsgBox "Error " & Err.Number & vbCrLf & Err.Description, vbCritical
End Sub

Private Function DetectDelimiter(ByVal txt As String) As String
    Dim arr As Variant
    arr = Array("،", ",", ";", "|", ":", "-")

    Dim i As Long
    For i = LBound(arr) To UBound(arr)
        If InStr(1, txt, arr(i)) > 0 Then
            DetectDelimiter = arr(i)
            Exit Function
        End If
    Next i

    DetectDelimiter = ""
End Function

Private Sub QuickSort(ByRef arr() As Double, ByVal low As Long, ByVal high As Long, ByVal desc As Boolean)
    Dim i As Long, j As Long
    Dim pivot As Double, tmp As Double

    i = low
    j = high
    pivot = arr((low + high) \ 2)

    Do While i <= j

        If desc Then
            Do While arr(i) > pivot: i = i + 1: Loop
            Do While arr(j) < pivot: j = j - 1: Loop
        Else
            Do While arr(i) < pivot: i = i + 1: Loop
            Do While arr(j) > pivot: j = j - 1: Loop
        End If

        If i <= j Then
            tmp = arr(i)
            arr(i) = arr(j)
            arr(j) = tmp
            i = i + 1
            j = j - 1
        End If

    Loop

    If low < j Then QuickSort arr, low, j, desc
    If i < high Then QuickSort arr, i, high, desc
End Sub

طريقة الاستخدام

• افتح Word
• اضغط ALT + F11
• Insert >-->> Module
• الصق الكود
• ارجع وحدد الأرقام داخل المستند
• شغل الماكرو: SortSelectedNumbersInWord

[قلم.رصاص]

ممكن نعدل

• كود الماكرو فى المودويل
• نعمل نموذج يفتح لما نعمل رن للماكرو

من النموذج نحدد شكل الفواصل اللى احنا عاوزينها ونحدد شكل الفرز والترتيب تصاعدى / تنازلى بدل الرسائل 

لو حد مهتم بالموضوع ده وحابيين نعمل النموذج ونعدل الكود عرفونى