اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

ارجو المساعدة لعمل ترتيب بشكل معين بالكود او بالمعادلات


الردود الموصى بها

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

اخي الكريم

جرب الكود التالي

Sub AL_KHALEDIفرزمخصص()
Set Rn1 = [A1]
Set Rn2 = [D1]
Set Rn1 = Range(Rn1, Rn1(Cells(1000, Rn1.Column).End(xlUp).Row, 1))
CLC1 = Application.CustomListCount
Application.AddCustomList ListArray:=Rn1
On Error GoTo Error:
CLC2 = Application.CustomListCount
L1 = Cells(Rows.Count, Rn2.Column).End(xlUp).Row
Set Rn3 = Range(Rn2, Rn2(L1, 1))
Dim Arr()
For Each Rc1 In Rn1.Cells
If Application.CountIf(Rn3, Rc1) = 0 Then
ReDim Preserve Arr(L2)
Arr(L2) = Rc1.Value
L2 = L2 + 1
Rn2(L1 + L2, 1).Value = Rc1.Value
End If
Set Rn3 = Range(Rn2, Rn2(L1 + L2, 1))
Next Rc1
Rn3.Sort Rn3(1, 1), xlAscending, Header:=xlNo, OrderCustom:=CLC2 + 1
For Each Rc3 In Rn3.Cells
If Not IsError(Application.Match(Rc3, Arr, 0)) Then Rc3.Value = ""
Next Rc3
Error:
If CLC2 > CLC1 Then
Application.DeleteCustomList ListNum:=CLC2
End If
Set Rn1 = Nothing: Set Rn2 = Nothing: Set Rn3 = Nothing
Erase Arr
End Sub

في امان الله

  • Like 1
رابط هذا التعليق
شارك

السلام عليكم

 

تم العمل بالكود التالي:

Const Adr As String = "I13"
Sub Macro1()
Dim Rng1 As Range, Rng2 As Range, Cel As Range
Dim R As Integer
Set Rng1 = Range("A1:A11")
Set Rng2 = Range("D1:D11")

For Each Cel In Rng1
    R = R + 1
    If WorksheetFunction.CountIf(Rng2, CStr(Cel)) Then
        Range(Adr).Cells(R, 1).Value = Cel.Value
    End If
Next
For Each Cel In Rng2
    If WorksheetFunction.CountIf(Rng1, CStr(Cel)) = 0 Then
        R = R + 1
        Range(Adr).Cells(R, 1).Value = Cel.Value
    End If
Next
End Sub

شاهد المرفق 2003

ترتيب بشكل معين.rar

  • Like 1
رابط هذا التعليق
شارك

السلام عليكم

الاستاذ الخالدي حفظك الله

وحشتنى اعمالك يارجل

اسأل الله ان تكون بأحسن حال

كود في قمة الاحتراف

بارك الله فيك وجزاك خيرا

تقبل مروري

رابط هذا التعليق
شارك

حيا ومرحبا استاذ عبدالله باقشير

كذا الاخ فضل محضوظ جداً

لمشاركة الاساتذه الكبار في موضوعه

كود مختصر جزاك الله خيراً

تحياتي وشكري للجميع

في امان الله

رابط هذا التعليق
شارك

السلام عليكم

اخي الحبيب الخالدي .......لم اشاهد مشاركتك

عموما زيادة في الخير ............جزاكم الله خيرا.....تقبلوا تحياتي وشكري

 

اخي الحبيب عباد..........جزاكم الله خيرا.....تقبلوا تحياتي وشكري

رابط هذا التعليق
شارك

الاستاذ الفاضل / الخالدى باشا ...................... صاحب الاعمال الرائعة والجميلة

العالم الكبير / عبدالله باقشير  ........................ عالمنا الجليل وصاحب الافكار المبهرة

عمل رائع لاستاذان كبيران كنت محظوظ بمشاركتهم .

تسلم الايادى والفقول المبدعة

دائما تمتعونا باعمالكم الجميلة مثلكم 

الف شكر على حلكم الرائع 

جزاكم الله كل خير ودائما تمتعونا بأعمالكم الخالدة والممتعة 

وشكرا

 

رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information