كود ترتيب الصفحات من الاصغر الى الاكبر

[رشبد]

السلام عليكم ورحمة الله

الاخوة الكرام

عندي ملف اكسيل يحتوي اكثر من 300 صفحة التسمية بالارقام من 1 الى اخر رقم باستثناء الصفحة الرئيسية  و تجميع 

وجزاكم الله خيرا

Book1.xlsm

تم تعديل منذ 7 ساعات بواسطه رشبد

[عبدالله بشير عبدالله]

وعليكم السلام ورخمة الله وبركاته

اليك الكود

Sub ترتيب_الصفخات()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    On Error GoTo ErrorHandler
    
    Dim ws As Worksheet
    Dim dict As Object
    Dim key As Variant
    Dim sortedKeys() As Variant
    Dim i As Long, j As Long
    Dim temp As Variant
    Dim excludedSheets As Collection
    Dim mainSheet As String
    
    mainSheet = "الرييييسية"
    
    Set excludedSheets = New Collection
    excludedSheets.Add mainSheet
    excludedSheets.Add "تجميع"
    
    Set dict = CreateObject("Scripting.Dictionary")
    
    For Each ws In ThisWorkbook.Worksheets
        If Not IsInCollection(excludedSheets, ws.Name) Then
            If IsNumeric(ws.Name) Then
                dict.Add CLng(ws.Name), ws.Name
            End If
        End If
    Next ws
    
    sortedKeys = dict.Keys
    
    For i = LBound(sortedKeys) To UBound(sortedKeys) - 1
        For j = i + 1 To UBound(sortedKeys)
            If sortedKeys(i) > sortedKeys(j) Then
                temp = sortedKeys(i)
                sortedKeys(i) = sortedKeys(j)
                sortedKeys(j) = temp
            End If
        Next j
    Next i
    
    For i = LBound(sortedKeys) To UBound(sortedKeys)
        Worksheets(dict(sortedKeys(i))).Move After:=Worksheets(Worksheets.Count)
    Next i
    
    Worksheets(mainSheet).Activate
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
 '   MsgBox "تم ترتيب " & dict.Count & " ورقة رقمية بنجاح! ", vbInformation
    Exit Sub
    
ErrorHandler:
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "حدث خطأ: " & Err.Description, vbCritical
End Sub

Function IsInCollection(col As Collection, item As String) As Boolean
    Dim obj As Variant
    On Error GoTo NotInCollection
    IsInCollection = True
    obj = col(item)
    Exit Function
NotInCollection:
    IsInCollection = False
End Function

ترتيب الصفحات.xlsm

[رشبد]

نعم هذا ما اريد بالظبط 

كيف التعديل لاضافة استثناءات اخرى مثلا اريد التعديل على الكود لاستثناء صفحات اخرى

جزاك الله خيرا استاد عبدالله بشير عبدالله

[عبدالله بشير عبدالله]

2 ساعات مضت, رشبد said:

كيف التعديل لاضافة استثناءات اخرى مثلا اريد التعديل على الكود لاستثناء صفحات اخرى

 

اولا شكرا لدعاؤك لي 

 ثانيا الكود في الملف السابق يقوم بترتيب الصفحات ذات الارقام وبالتالي ستجد الصفحات الاخرى ذات الحروف وليس الارقام مستثناة  وتجدها بجانب بعضها

ولكن هناك احتمال الرغبة في استثناء صفخة او صفحات رقمية مثلا تريد استثناء صفخة 4 من الترتيب . هنا سيتم التعديل على الكود باظافة مصفوفة لتجميع الصفخات المستثناة

كل ما عليك فعلة هو التعديل في هذا الجزء من الكود  حيث اضفت لك صفحات افتراضية في الكود وليس في المصتف  مثل "ملخص", "إعدادات", "تعليمات يمكنك تعديلها باي اسم او اظافة صفحات اخرى باي عدد تشاء

    excludedSheets = Array("الرييييسية", "تجميع", "ملخص", "إعدادات", "تعليمات")

اليك الملف بالتعديل

ترتيب الصفحات1.xlsm

تحياتي

تم تعديل منذ 2 ساعات بواسطه عبدالله بشير عبدالله