sağa doğru yinelenen değer

[igultekin2000]

iyi çalışmalar;
şimdiye kadar hep normal yenilenen değer makrosunu sütunlarda kullandım. şimdi İP Perde çalışma sayfasının C sütunundaki isimleri Sayfa1 çalışma sayfasının B1 hücresinden sağa doğru yani C1-D1 ....şeklinde listelemek istiyorum. bununla ilgil örnek çalışma bulamadım. Teşekkürler.

 

[Korhan Ayhan]

Deneyiniz.

Sub Benzersiz_Liste()
    Dim SD As Worksheet, SO As Worksheet, Son As Long, Liste(), Dizi As Object, X As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set SD = Sheets("İP PERDELER")
    Set SO = Sheets("Sayfa1")
    
    Son = SD.Cells(Rows.Count, "A").End(3).Row
    Liste = SD.Range("C5:C" & Son).Value
    
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    For X = 1 To UBound(Liste, 1)
        If Liste(X, 1) <> "" Then Dizi.Item(Liste(X, 1)) = 1
    Next
    
    SO.Range("B1").Resize(1, Columns.Count - 1).ClearContents
    SO.Range("B1").Resize(1, Dizi.Count) = Application.Transpose(Application.Transpose(Dizi.Keys))
    
    Set Dizi = Nothing
    Set SD = Nothing
    Set SO = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

 

[igultekin2000]

Deneyiniz.

Sub Benzersiz_Liste()
    Dim SD As Worksheet, SO As Worksheet, Son As Long, Liste(), Dizi As Object, X As Long
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set SD = Sheets("İP PERDELER")
    Set SO = Sheets("Sayfa1")
   
    Son = SD.Cells(Rows.Count, "A").End(3).Row
    Liste = SD.Range("C5:C" & Son).Value
   
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    For X = 1 To UBound(Liste, 1)
        If Liste(X, 1) <> "" Then Dizi.Item(Liste(X, 1)) = 1
    Next
   
    SO.Range("B1").Resize(1, Columns.Count - 1).ClearContents
    SO.Range("B1").Resize(1, Dizi.Count) = Application.Transpose(Application.Transpose(Dizi.Keys))
   
    Set Dizi = Nothing
    Set SD = Nothing
    Set SO = Nothing
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Çok teşekkür ederim, Sorunsuz çalışıyor, iyi çalışmalar.