المطلوب عمل كود

[محمد زيدان2024]

المطلوب عمل كود ترتيب ابجدي للاسماء وعمل كود ترتيب تنازلي للمجموع @محمد هشام.

فرز.xlsb

[Saleh Ahmed Rabie]

12 ساعات مضت, محمد زيدان2024 said:

المطلوب عمل كود ترتيب ابجدي للاسماء وعمل كود ترتيب تنازلي للمجموع @محمد هشام.

فرز.xlsb 571.92 kB · 3 downloads

**كود VBA لترتيب الأسماء أبجديًا**

Sub SortNamesAlphabetically()

    Dim rng As Range
    Dim lastRow As Long

    ' تحديد نطاق البيانات
    Set rng = Range("A1:A100") ' تعديل النطاق حسب الحاجة

    ' الحصول على آخر صف في النطاق
    lastRow = rng.Rows.Count

    ' فرز النطاق أبجديًا
    rng.Sort Key1:=rng.Columns(1), Order1:=xlAscending, Header:=xlYes

End Sub

**كود VBA لترتيب المجموع تنازليًا**

Sub SortSumDescending()

    Dim rng As Range
    Dim lastRow As Long

    ' تحديد نطاق البيانات
    Set rng = Range("A1:B100") ' تعديل النطاق حسب الحاجة

    ' الحصول على آخر صف في النطاق
    lastRow = rng.Rows.Count

    ' فرز النطاق تنازليًا حسب المجموع في العمود B
    rng.Sort Key1:=rng.Columns(2), Order1:=xlDescending, Header:=xlYes

End Sub

**ملاحظات:**

* تأكد من تعديل نطاقات البيانات في أكواد VBA لتتوافق مع نطاق بياناتك الفعلي.
* يمكنك استخدام هذه الأكواد لترتيب البيانات في أي نطاق من ورقة العمل.
* إذا كنت ترغب في فرز البيانات حسب معايير متعددة، يمكنك استخدام طريقة `Sort` مع معلمات `Key2` و`Order2` و`Key3` و`Order3` وما إلى ذلك.
 

[محمد زيدان2024]

ارجو الحل @محمد هشام.

[محمد هشام.]

طلبك غير واضح بالنسبة لي  ربما لم استطع استوعابه يمكنك شرح المطلوب بشكل اكثر وضوحا عند الاجابة على هده الاسئلة 

اخي @محمد زيدان2024  ادا قمنا بترتيب كل عمود على حدى هدا سياثر على صحة البيانات المجاورة من تاريخ الميلاد وحتى عمود السنة  

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

 

 

[محمد زيدان2024]

منذ ساعه, محمد هشام. said:

طلبك غير واضح بالنسبة لي  ربما لم استطع استوعابه يمكنك شرح المطلوب بشكل اكثر وضوحا عند الاجابة على هده الاسئلة 

اخي @محمد زيدان2024  ادا قمنا بترتيب كل عمود على حدى هدا سياثر على صحة البيانات المجاورة من تاريخ الميلاد وحتى عمود السنة  

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

فعلا المطلوب كود ترتيب ابجدي للعمود c ( الاسماء) مع تحديد جميع البيانات وكود اخر بترتيب تنازلى للمجموع للعمود i مع مع تحديد جميع البيانات كل كود منفصل عن الاخر واكيد لو رتبنا ابجدي البيانات هتختلف بما فيه المجموع ولو رتبنا تنازلى للمجموع البيانات هتختلف بما فيها الاسم

تم تعديل الجمعة at 12:41 بواسطه محمد زيدان2024

[محمد هشام.]

تمام اخي محمد 

 

تم تعديل الجمعة at 20:21 بواسطه محمد هشام.

[محمد زيدان2024]

تمام اخى بس المجموع  حضرتك عملته تصاعدى والمطلوب تنازلى من الاكبر للاصغر

[محمد هشام.]

تفضل اخي @محمد زيدان2024 تم تعديل الاكواد لتتناسب مع طلبك 

Option Compare Text
Public Property Get f() As Worksheet: Set f = Worksheets("12 د بنون")
End Property
'================29/06/2024     by:MOHAMEED HICHAM    www.officena.net     "منتدى الاكسيل" '
'===========================================================================================
Sub TriTotal_Descending_Order()
'ترتيب تنازلي
Dim a()
Dim r As Range

  a = f.Range("C11:J" & f.[C65000].End(xlUp).Row).Value
  Set r = f.Range("C11:J" & f.[C65000].End(xlUp).Row)
  
  ' تحديد نطاق معين
   'a = [C11:J38].Value: Set r = [C11:J38]
   
   ' <<=======عمود المجموع========
   Call Quick(a(), LBound(a), _
          UBound(a), 7, False): r.Value2 = a
End Sub
'**********فرز سريع*************
Sub Quick(a(), gauc, droi, Cnt, ordre)
 Total = a((gauc + droi) \ 2, Cnt)
 Rng = gauc: d = droi
 Do
  If ordre Then
    Do While a(Rng, Cnt) < Total: Rng = Rng + 1: Loop
    Do While Total < a(d, Cnt): d = d - 1: Loop
  Else
    Do While a(Rng, Cnt) > Total: Rng = Rng + 1: Loop
    Do While Total > a(d, Cnt): d = d - 1: Loop
  End If
   If Rng <= d Then
     For i = LBound(a, 2) To UBound(a, 2)
       temp = a(Rng, i): a(Rng, i) = a(d, i): a(d, i) = temp
     Next i
     Rng = Rng + 1: d = d - 1
   End If
  Loop While Rng <= d
  If Rng < droi Then Call Quick(a, Rng, droi, Cnt, ordre)
  If gauc < d Then Call Quick(a, gauc, d, Cnt, ordre)
End Sub
'************************************
Sub Tri_Colmun_Name()
 'ترتيب ابجدي
 Dim clé() As String, index() As Long, Rng As Range
 a = f.Range("C11:J" & f.[C65000].End(xlUp).Row).Value
 Dim b(): Set Rng = f.[C11]
 ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2))
 Set rCrit = CreateObject("System.Collections.Sortedlist")
 For i = LBound(a) To UBound(a)
   rCrit.Add a(i, 1) & i, i
 Next i
 For tmp = LBound(a) To UBound(a)
  For arr = LBound(a, 2) To UBound(a, 2)
    b(tmp, arr) = a(rCrit.GetByIndex(tmp - 1), arr)
  Next arr
 Next tmp
Rng.Resize(UBound(b), UBound(b, 2)).Value2 = b
End Sub
'*************************************
Sub Tri_Total_Colmun()
'ترتيب تصاعدي
 Dim clé() As String, index() As Long, Rng As Range
 a = f.Range("C11:J" & f.[C65000].End(xlUp).Row).Value
 Dim b(): Set Rng = f.[C11]
 ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2))
 Set rCrit = CreateObject("System.Collections.Sortedlist")
 For i = LBound(a) To UBound(a)
   rCrit.Add a(i, 7) & i, i
 Next i
 For tmp = LBound(a) To UBound(a)
  For arr = LBound(a, 2) To UBound(a, 2)
    b(tmp, arr) = a(rCrit.GetByIndex(tmp - 1), arr)
  Next arr
 Next tmp
Rng.Resize(UBound(b), UBound(b, 2)).Value2 = b
End Sub

 

فرز V3.xlsb

[mahmoud nasr alhasany]

احسنت وبارك الله فيك ا/ محمد هشام 

[محمد زيدان2024]

جهد مشكور بس الاكود لازم ادوس عليها مرتين علشان تشتغل

[محمد هشام.]

45 دقائق مضت, محمد زيدان2024 said:

جهد مشكور بس الاكود لازم ادوس عليها مرتين علشان تشتغل

 

 انت لم تنتبه انه لديك نفس قيمة المجموع  للاسماء  🤔🤔🤔

فارس محمد عبد الرازق اسماعيل   676 

عمار سيد عبد الرازق اسماعيل   676 

الكود يقوم بتحديثها  جرب تغيير الرقم وسوف تلاحظ الفرق 

 

تم تعديل الجمعة at 21:43 بواسطه محمد هشام.

[محمد زيدان2024]

عند الضغط على الورقة اخري والرجوع لنفس الورقة الرتيب الابجدي لايعمل ولا التصاعدي ويعمل التنازلي

[محمد هشام.]

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

وللتأكد قمت بتجربته على جهاز اخر انظر الرابط التالي  👇

https://streamable.com/3m40n4

رغم انني متأكد من صحة الاكواد وبما ان كود التنازلي يعمل جرب هدا للتصاعدي  و الترتيب الابجدي ووافينا بالنتيجة 

Sub Tri_Names_Ordre()
 'ترتيب ابجدي
Dim a()
Dim r As Range
  a = f.Range("C11:J" & f.[C65000].End(xlUp).Row).Value
  Set r = f.Range("C11:J" & f.[C65000].End(xlUp).Row)
   ' <<=======عمود الاسم========
   Call Quick(a(), LBound(a), _
          UBound(a), 1, True): r.Value2 = a
End Sub
'*************
Sub Tri_Ordre_croissant()
'ترتيب تصاعدي
Dim a()
Dim r As Range
  a = f.Range("C11:J" & f.[C65000].End(xlUp).Row).Value
  Set r = f.Range("C11:J" & f.[C65000].End(xlUp).Row)
   ' <<=======عمود المجموع========
   Call Quick(a(), LBound(a), _
          UBound(a), 7, True): r.Value2 = a

End Sub

 

 

 

فرز V4.xlsb

تم تعديل بالامس في 00:24 بواسطه محمد هشام.

[محمد زيدان2024]

تمام شكرا اخي بارك الله فيك بس لو امكن نغير ده تتنازلي لو امكن

Sub Tri_Total_column()
'ترتيب تنازلي
 Dim clé() As String, index() As Long, Rng As Range
 a = [C11:J38].Value: Set Rng = [c11]
 Dim b()
 ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2))
 Set rCrit = CreateObject("System.Collections.Sortedlist")
 For i = LBound(a) To UBound(a)
   rCrit.Add a(i, 7) & i, i
 Next i
 For tmp = LBound(a) To UBound(a)
  For arr = LBound(a, 2) To UBound(a, 2)
    b(tmp, arr) = a(rCrit.GetByIndex(tmp - 1), arr)
  Next arr
 Next tmp
Rng.Resize(UBound(b), UBound(b, 2)).Value2 = b
End Sub

 

تم تعديل بالامس في 09:34 بواسطه محمد زيدان2024

[محمد هشام.]

بطريقة اخرى 

Option Compare Text
Public Property Get F() As Worksheet: Set F = Worksheets("12 د بنون")
End Property
Public Property Get lr() As Long: lr = F.Columns("C:J").Find(What:="*", _
                SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
End Property

Sub Sort_Names()
 'ترتيب ابجدي
Dim OneRng As Range
  Set OneRng = F.Range("C11:J" & lr)
  With OneRng
    .Sort Key1:=.Columns(1), Order1:=xlAscending, Header:=xlNo
  End With
End Sub
'***********
Sub Sort_TOTAL()
'ترتيب تنازلي
Dim OneRng As Range
  Set OneRng = F.Range("C11:J" & lr)
  With OneRng
    .Sort Key1:=.Columns(7), Order1:=xlDescending, Header:=xlNo
  End With
End Sub
'*********
Sub Sort_TOTAL2()
'ترتيب تصاعدي
Dim OneRng As Range
  Set OneRng = F.Range("C11:J" & lr)
  With OneRng
    .Sort Key1:=.Columns(7), Order1:=xlAscending, Header:=xlNo
  End With
End Sub

 

فرز Final.xlsb

تم تعديل منذ 22 ساعات بواسطه محمد هشام.

[محمد زيدان2024]

شكرا بارك الله فيك فعلا انتا موسوعة اكسل @محمد هشام.