معادلة ايجاد الأسماء

[2saad]

اخواني اعضاء المنتدي بعد سلام الله عليكم ورحمة الله وبركاته

المطلوب بالمرفقmarem.xlsx

[محمد هشام.]

الطريقة الصحيحة هي استخراج الاسماء  بعد مقارنة الأعمدة في عمود مغاير  لاكن بما انك تريد  استخراج النتائج  تحت آخر خلية بها بيانات ربما يتطلب منك ذالك استخدام الأكواد. 

 

[2saad]

شكرا لرد حضرتك يا استاذ محمد 

ممكن باي طريقة المهم يتحقق اللمطلوب

[بلانك]

ياريت بالمثل نفس السؤال

[محمد هشام.]

ادن جرب هدا ووافينا بالنتيجة 

Sub Compare_Col()
Dim lr As Long, i As Long
Dim WS As Worksheet: Set WS = Worksheets("Sheet1")
On Error Resume Next
lr = WS.Columns("A:C").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    For i = 1 To lr
    Application.ScreenUpdating = False
    If WorksheetFunction.CountIf(Range("C1:C" & lr), Range("A" & i)) < 1 Then
    Cells(Rows.Count, 3).End(xlUp).Offset(1).Value = Range("A" & i).Value
    End If
    Next i
    Application.ScreenUpdating = True
End Sub

 

marem v2.xlsb

[2saad]

شكرا جزيلا استاذنا الفاضل وبارك الله فيك

[بلانك]

بارك الله فيك

[2saad]

ممكن يا استاذ محمد سؤال أو استفسار

ممكن نثبت العمود A  ونجعل الكود يشمل عدد كبير من الأعمدة يعني يشمل ( C و D و E و F ) بدلا من C فقط

ممكن حضرتك تخبرني ماذا اغير في الكود 

ويكون بارك الله فيك ومعلش احنا بنتعب حضرتك معانا

[محمد هشام.]

2 ساعات مضت, 2saad said:

ممكن نثبت العمود A  ونجعل الكود يشمل عدد كبير من الأعمدة يعني يشمل ( C و D و E و F ) بدلا من C فقط

جرب هدا

Sub Uniques()
                            'Col_C_D_E_F
Dim Rng As Range, lr&
Dim ws As Worksheet: Set ws = Worksheets("Sheet1")
lr = ws.Columns("A:F").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
For Each Rng In Range("A1:A" & lr)
    If WorksheetFunction.CountIf(Range("C1:F" & lr), Rng) = 0 Then
        Range("C" & Rows.Count).End(xlUp).Offset(1) = Rng
    
    End If
Next
End Sub

 

marem v3.xlsb

تم تعديل يناير 31, 2024 بواسطه محمد هشام.

[2saad]

شكرا يا استاذ محمد لردك

حضرتك جربت الملف

لا يعمل

[بلانك]

الكود يعمل بكفاءه

 

[محمد هشام.]

12 دقائق مضت, 2saad said:

حضرتك جربت الملف

لا يعمل

https://streamable.com/ktq9k9

[2saad]

شكرا لحضرتك وبارك الله فيك

 حضرتك عند الضغط علي الزر المكتوب عليه ( c و d و e و f ) لا يرحل الأسماء الموجودة في العمود (a) وغير موجودة في في هذه الأعمدة ( c و d و e و f )

يعني زي ما يحدث عند الضغط علي زر ( c ) يحدث في الضغط علي زر (c و d و e و f )

يا ريت يكون وصلت الفكرة

وشكرا علي تعبك معنا 

[محمد هشام.]

بالعكس اظن انه يفعل دالك ممكن ترفع صورة للخطا الدي يواجهك  او ارفاق عينة للنتائج المتوقعة للتوضيح اكثر  

https://streamable.com/vememx

 

تم تعديل فبراير 1, 2024 بواسطه محمد هشام.

[2saad]

المطلوب مرة أخري حضرتك marem v3 (1).xlsb

[محمد هشام.]

marem v4.xlsb

[2saad]

الله ينور عليك وبارك الله فيك وأكثر الله من أمثالك

[محمد هشام.]

 

ربما لو قمت بارفاق عينة للنتائج المتوقعة اول مرة وبنفس تنسيق ملفك الاصلي  لكنا في غنى عن كل هده المحاولات ووفرت علينا وعلى نفسك الكثير 

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

الرجاء  اخي  @2saad أخذ هده الملاحظات بعين الاعتبار في المشاركات المقبلة.  

Option Explicit
Sub test()

    Dim lr As Long, i As Long, j As Long
    Dim strCol As String
    Dim WS As Worksheet: Set WS = Worksheets("Sheet1")
    
    Application.ScreenUpdating = False
    lr = WS.Columns("A:R").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    
    'الاعمدة من C الى  F
    For i = 2 To 6
        strCol = Split((WS.Columns(i).Address(, 0)), ":")(0) 
        For j = 1 To lr
            If WorksheetFunction.CountIf(WS.Range(strCol & "1:" & strCol & lr), WS.Range("A" & j)) = 0 Then
                WS.Cells(Rows.Count, strCol).End(xlUp).Offset(1).Value = WS.Range("A" & j).Value
            End If
        Next j
    Next i
    
    Application.ScreenUpdating = True

End Sub

 

تم تعديل فبراير 1, 2024 بواسطه محمد هشام.
اختصار للكود السابق

[2saad]

الله يبارك فيك دنيا وآخرة