تشغيل ماكرو ترتيب تصاعدي وتنازلي لاكثر من عمود

[commandos1975]

السلام عليكم اريد معرفة طريقة تشغيل ميكرو الترتيب علي اكثر من عمود اي عند التوجة للمسلسل يرتب المسلسل وعند التوجه لعمود الاسم يرتب الاسم وعند التوجة لعمود المستوي يرتب المستوي

الضغطة الاولي تصاعدي والضغطة الثانية تنازلي

agh.xlsm

[سليم حاصبيا]

جرب هذا الملف

Option Explicit

 Sub Sort_me(ByVal rag As Range, ByVal col As Integer, Ad As Integer)
 rag.Sort key1:=rag.Cells(1, col), order1:=Ad, Header:=1
 End Sub
 '+++++++++++++++++++++++++++++++++++++++
Private Sub ToggleButton1_Click()
Dim My_col
If (Selection.Address(0, 0) = "A1" Or _
  Selection.Address(0, 0) = "B1" Or _
  Selection.Address(0, 0) = "C1") And _
  Selection.Count = 1 Then
  My_col = Selection.Cells(1, 1).Column
 If ToggleButton1 = True Then
  Call Sort_me(Selection.CurrentRegion, My_col, 2)
 ToggleButton1.Caption = "تنازلي حسب خلية  " & Cells(1, My_col)
 Else
  Call Sort_me(Selection.CurrentRegion, My_col, 1)
  ToggleButton1.Caption = "تصاعدي حسب خلية " & Cells(1, My_col)
 End If
  
Else
  Exit Sub
End If

End Sub

الملف مرفق

commendos_sort.xlsm

[commandos1975]

ربنا يبارك فيك يا غالي شغل عالي

استفسار هذا الكود يعمل مع اي ملف اي ل اعداد كثيرة من الاعمدة

وجدت هذا الكود كيف يمكنني الاستفادة منه

Sub SortTable()


  Dim myTable As Range
  Dim myColToSort As Long
  Dim curWks As Worksheet
  Dim mySortOrder As Long
  Dim LastRow As Long
  Dim iCol As Integer
  Dim strCol As String
  iCol = 170  '10 columns
  strCol = "A"  ' column to check for last row

  Set curWks = ActiveSheet
  With curWks
    ActiveSheet.Unprotect
    myColToSort = .Shapes(Application.Caller).TopLeftCell.Column
    LastRow = .Cells(.Rows.Count, strCol).End(xlUp).Row
    Set myTable = .Range("a6:a" & LastRow).Resize(, iCol)
    If .Cells(myTable.Row + 1, myColToSort).Value _
      < .Cells(LastRow, myColToSort).Value Then
        mySortOrder = xlDescending
    Else
        mySortOrder = xlAscending
    End If
    myTable.Sort Key1:=.Cells(myTable.Row, myColToSort), _
              Order1:=mySortOrder, _
              Header:=xlYes
  End With

    ActiveSheet.Protect
End Sub

اجعل وقت لغيرك فى طلب الإستفسار والمشاكل, طالما تحصلت على الإجابة المطلوبة