şartlı benzersiz aktarma

[metinavci23]

Arkadaşlar kolay gelsin herkese.Ben şartlı benzersiz aktarma aypmak istiyorum.ekteki dosyada ne yapmak istediğimi izah etmeye çalıştım.aslında ben benzersiz aktarmayı yapıyorum ama herhangi bir şart ilave ettiğimde makro çalışmıyor.şimdiden herkese teşekkür ederim

 

[Ömer]

Merhaba,

Bu şekilde deneyiniz.

Sub Aktar()
 
Dim S2 As Worksheet, c As Long, i As Long
 
Set S2 = Sheets("Sayfa2")
S2.Range("B2:B" & Rows.Count).ClearContents
 
Sheets("Sayfa1").Select
 
c = 1
For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
    If Range("A" & i) <> "" And Evaluate("=SumProduct((B2:B" _
    & i & "=B" & i & ")*(A2:A" & i & "<>""""" & "))") = 1 Then
        c = c + 1
        S2.Cells(c, "B") = Cells(i, "B").Value
    End If
Next i
 
End Sub

.