ترحيل بدون تكرار

[محمود رمضان السمري]

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

عايز كود لترحيل القيم فيالعمودB من الخليه b5:b100 في sheet1   

الي نفس العمود و الخلايا في sheet2 

بغض النظر إلي رأس العمود

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

ولكم جزيل الشكر

[محمد هشام.]

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

جرب هل هدا ما تقصده

Sub SansDoublons()
    Dim dict As Object, tmp As Variant
    Dim cell As Range, i As Long
    
    Dim f As Worksheet: Set f = Sheets("Sheet1")
    Dim WS As Worksheet: Set WS = Sheets("Sheet2")
 
 Application.ScreenUpdating = False
 Set dict = CreateObject("Scripting.Dictionary")
    For Each cell In f.Range("b5:b100")
    If Len(cell.Value) > 0 And Not dict.exists(cell.Value) Then
        dict.Add cell.Value, Nothing
    End If
    Next cell
        If dict.Count > 0 Then
        WS.Range("b5:b100").ClearContents
        tmp = dict.Keys
                For i = LBound(tmp) To UBound(tmp)
            WS.Cells(i + 5, 2).Value = tmp(i)
        Next i
    End If
Application.ScreenUpdating = True
End Sub

لتشغيل الماكرو تلقائيا عند الغيير في عمود (b) ورقة 1  في حدث Sheet1

 

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Me.Range("b5:b100")) Is Nothing Then
        SansDoublons
    End If
End Sub

 

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

تم تعديل أغسطس 26, 2024 بواسطه محمد هشام.

[محمود رمضان السمري]

أستاذ محمد هشام 

لك مني كل الاحترام والتقدير علي مجهودك

ولم تبخل بأي معلومه 

شكرا أستاذ محمد