السلام عليكم ورحمة الله وبركاته
إليكم كود يقوم بمقارنة القيم في عمودين ثم استخراج القيم الفريدة من العمودين ثم ترتيب النتائج تصاعدياً.
بفرض أن لديك عمودين العمود الأول والعمود الرابع ، والمطلوب إجراء عملية مقارنة بينهما بحيث يتم استخراج القيم الفريدة من العمودين (أي القيم الغير مكررة) .....
أي يتم مقارنة العمود الأول بالعمود الرابع والأرقام الفريدة توضع في العمود الثاني ويتم ترتيبها تصاعدياً ، ثم مقارنة العمود الرابع بالعمود الأول والأرقام الفريدة توضع في العمود الثالث ويتم ترتيبها تصاعديا.
إليكم الكود الذي يؤدي الغرض ، ويوضع الكود في موديول عادي Standard Module :
Sub Uniques_In_Two_Lists()
Dim Cel As Range
Dim Rng1 As Range
Dim Rng2 As Range
Set Rng1 = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Set Rng2 = Range("D2:D" & Cells(Rows.Count, "D").End(xlUp).Row)
Application.ScreenUpdating = False
Range("B2:C1000").ClearContents
Range("A1").CurrentRegion.Offset(1).Interior.Color = xlNone
For Each Cel In Rng1
If WorksheetFunction.CountIf(Rng2, Cel) = 0 Then
Cel.Interior.Color = rgbSilver
Range("B" & Rows.Count).End(xlUp).Offset(1) = Cel
End If
Next Cel
For Each Cel In Rng2
If WorksheetFunction.CountIf(Rng1, Cel) = 0 Then
Cel.Interior.Color = rgbOlive
Range("C" & Rows.Count).End(xlUp).Offset(1) = Cel
End If
Next Cel
Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row).Sort Key1:=Range("B2"), Order1:=xlAscending
Range("C2:C" & Cells(Rows.Count, "C").End(xlUp).Row).Sort Key1:=Range("C2"), Order1:=xlAscending
Application.ScreenUpdating = True
End Sub
إعداد / ياسر خليل أبو البراء
السلام عليكم ... كود رائع جداً ...بارك الله
ردحذفوعليكم السلام ..الأروع هو مرروك العطر بالموضوع ..جزيت خيراً أبا يوسف
ردحذفهذا ما كنت ابحث عنه
ردحذفكود بطل من استاذ بطل
الحمد لله أن وجدت ضالتك أخي الكريم علي ..قل الحمد لله
ردحذفالحمد لله على جميع نعمه نا نعلمه منها وما لا نعلمه
ردحذفجزاك الله عنا كل خير
وجزيت خيراً أخي الفاضل بمثل ما دعوت لي وزيادة
ردحذفطول عمرك برنس ومبدع ... أحمد شمس
ردحذفمنور المدونة يا كبير .. بارك الله فيك وجزاك الله خيراً
ردحذفجزيت خيرا
ردحذفوجزيت خيراً بمثل ما دعوت لي أخي العزيز عبد الرحمن
ردحذف