كود ينقل مجال بلا تكرار

[saad abed]

اخوتى

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

كنت امل من الكود ان ينقل المجال بلا تكرار ولكن دون جدوى فما الخلل

ام الكود تالف

Sub end_report()
Dim c As Range
Dim coll As New Collection
On Error Resume Next
For i = 6 To 200
For Each c In Sheets("saad").[b7:b1500]
coll.Add c.Value
Cells(i, 4) = c.Value
i = i + 1
Next
Next
End Sub
 

1.rar

تم تعديل مايو 26, 2013 بواسطه سعد عابد

[احمد عبد الناصر]

السلام عليكم

 

جرب هذه 

Sub end_report()
l = Sheets("saad").Range("b" & Rows.Count).End(xlUp).Row
Sheets("saad").Range("b6:b" & l).Copy
Range("d6").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
Range("d6:d" & l).RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

تحياتي

[عبدالله باقشير]

السلام عليكم

الشكر واصل لاخي الحبيب احمد عبد الناصر

 

بخصوص الكود في المشاركة 1

هذا تعديله

Sub end_report()
Dim c As Range
Dim coll As New Collection

For Each c In Sheets("saad").[b7:b1500]
    On Error Resume Next
    coll.Add c.Value, CStr(c)
    If Err Then
        Err.Clear
    Else
        Cells(i + 6, 4) = c.Value
        i = i + 1
    End If
Next
End Sub

في امان الله

[saad abed]

اخى احمد عبدالناصر

كل الشكر والتقدير

جزاك الله خيرا

بحس ان اكوادك بسيطة وممتازة اتابع ردودك لاتعلم منك الكثير

الف شكر

[saad abed]

اخى العلامة عبدالله باقشير

اشكرك كل الشكر

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

نتعلم على يديك الكثير والكثير

تعبناك معانا

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

كنت لم اجرب الكود بعد

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

اكوادك وتعديلاتك تتم باحتراف

بارك الله فيك

تم تعديل مايو 26, 2013 بواسطه سعد عابد