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

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

من الأمور التي نحتاجها أحيانا أن نرتب مجموعة أرقام على غرار (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