اختصار كود VBA لعمل SORT للجداول

[ابوحمزه المصرى]

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

Sub autofiltr()
    ActiveWorkbook.Worksheets("ورقة1").ListObjects("الجدول1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("ورقة1").ListObjects("الجدول1").Sort.SortFields.Add _
        Key:=Range("الجدول1[[#All],[القاهرة]]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("ورقة1").ListObjects("الجدول1").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.Worksheets("ورقة1").ListObjects("الجدول2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("ورقة1").ListObjects("الجدول2").Sort.SortFields.Add _
        Key:=Range("الجدول2[[#All],[اسيوط ]]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("ورقة1").ListObjects("الجدول2").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.Worksheets("ورقة1").ListObjects("الجدول3").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("ورقة1").ListObjects("الجدول3").Sort.SortFields.Add _
        Key:=Range("الجدول3[[#All],[المنيا]]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("ورقة1").ListObjects("الجدول3").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.Worksheets("ورقة1").ListObjects("الجدول4").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("ورقة1").ListObjects("الجدول4").Sort.SortFields.Add _
        Key:=Range("الجدول4[[#All],[قنا]]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("ورقة1").ListObjects("الجدول4").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.Worksheets("ورقة1").ListObjects("الجدول5").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("ورقة1").ListObjects("الجدول5").Sort.SortFields.Add _
        Key:=Range("الجدول5[[#All],[اسوان]]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("ورقة1").ListObjects("الجدول5").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

 array.rar

تم تعديل أكتوبر 7, 2015 بواسطه صلاح المصرى
تكرار المرفق

[ابوحمزه المصرى]

الا يوجد حل

[ابوحمزه المصرى]

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

Sub auto_filtr()
Dim asd(0 To 4)
Dim asdS(0 To 4)
Dim i As Integer
Dim J As Integer
asd = Array(Range("A1"), Range("B1"), Range("C1"), Range("D1"), Range("E1"))
asdS = Array(ListObjects("الجدول1"), ListObjects("الجدول2"), ListObjects("الجدول3"), ListObjects("الجدول4"), ListObjects("الجدول5"))
For asd(i) = LBound(asd) To UBound(asd)
For asdS(J) = LBound(asdS) To UBound(asdS)
    ActiveWorkbook.Worksheets("ورقة1").asdS.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("ورقة1").asdS.Sort.SortFields.Add _
        Key:=asd(i), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("ورقة1").asdS.Sort
        .Header = xlYes
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Next i
    Next J
  End Sub

 

تم تعديل أكتوبر 10, 2015 بواسطه صلاح المصرى

[ابوحمزه المصرى]

هذا آخر اختصار للكود قمت بالتوصل اليه  ويعمل جيدا لمن يريد الاضافه

Sub auto_filtr()
   With ActiveWorkbook.Worksheets("ورقة1").ListObjects("الجدول1").Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("a1"), Order:=xlAscending
    .Apply
    End With
    With ActiveWorkbook.Worksheets("ورقة1").ListObjects("الجدول2").Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("b1"), Order:=xlAscending
    .Apply
    End With
    With ActiveWorkbook.Worksheets("ورقة1").ListObjects("الجدول3").Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("c1"), Order:=xlAscending
    .Apply
    End With
    With ActiveWorkbook.Worksheets("ورقة1").ListObjects("الجدول4").Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("d1"), Order:=xlAscending
    .Apply
    End With
    With ActiveWorkbook.Worksheets("ورقة1").ListObjects("الجدول5").Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("e1"), Order:=xlAscending
    .Apply
    End With
    End Sub

 

[احمد عبد الناصر]

السلام عليكم 

جرب اضافة هذا السطر في البداية

Application.ScreenUpdating = False

وهذا في النهاية

    Application.ScreenUpdating = True

تحياتي

[ابوحمزه المصرى]

اولاً شكراً على تفاعلك فى الموضوع اخى الحبيب احمد عبدالناصر وشكراً آخر على الاضافه الجميله ... لكن كنت اود ان استخدم ARRAY او FOR NEXT لان هذا مجرد مثال اما الموضوع الاصلى فعدد الجداول فيه اكبر بكثير.. اتمنى من اخوانى اعضاء اوفيسنا التفاعل فى الموضوع لأهميته الكبيره.

[الـعيدروس]

السلام عليكم

جرب هذا الكود ان شاء الله يفي بالغرض

Sub Ali_Sort_Tble()
Dim Tb As ListObject
On Error Resume Next
For Each Tb In ActiveSheet.ListObjects
With Tb
.Range.Sort key1:=.ListColumns(1), order1:=xlAscending, _
  Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
Next
On Error GoTo 0
End Sub

 

 

[ابوحمزه المصرى]

تمام اخى الفاضل الـعيدروس حل ممتاز .. بارك الله فيك