koşullu mükerer

[numan şamil]

Merhaba
Ekli dosyada açıklama yaptım
A sutununda mükerer veriller var
C sutununda bazı veriler var
C sutununda boş olan hücrelere A sutunundaki mükererlere denk gelen C sutunundaki verileri yazdırmak istiyorum

 

[ÖmerFaruk]

Sub Mukerrer()
    Dim Dizi, Dict, Liste, i As Long
    'Aralığınız A4:Cxxx" aralığındaolduğunu varsaydım
    'Eğer başlık yada alt satırlar ya da sağda solda başka sütunlar varsa revize edilmelidir
    Dizi = Range("A4").CurrentRegion.Value
    Set Dict = CreateObject("Scripting.Dictionary")
    ReDim Liste(1 To UBound(Dizi, 1), 1 To 1)
    For i = 1 To UBound(Dizi, 1)
        Liste(i, 1) = Dizi(i, 3)
        If Dizi(i, 1) <> "" Then
            If Not Dict.Exists(Dizi(i, 1)) Then
                Dict.Add Dizi(i, 1), Dizi(i, 3)
            Else
                If Dizi(i, 3) <> "" Then Dict(Dizi(i, 1)) = Dizi(i, 3)
            End If
        End If
    Next i
    For i = 1 To UBound(Dizi, 1)
        If Dizi(i, 1) <> "" Then Liste(i, 1) = Dict(Dizi(i, 1))
    Next i
    Range("H4").Resize(UBound(Dizi, 1), 1) = Liste
    Erase Dizi: Erase Liste: Set Dict = Nothing
End Sub

 

[numan şamil]

Teşekkürler
Kendi dosyama uyarladım