Makro Güncelleme

[igultekin2000]

İyi günler; tek sütunda yenilenen değer makrosu kullanıyorum, bunu üç sütunluya çevirmek istiyorum. Teşekkürler.

Sub kod()
    Dim SD As Worksheet: Set SD = Sheets("Sayfa1")
    Dim SO As Worksheet: Set SO = Sheets("Sayfa2")
    Dim liste(), dizi()
    son = SD.Cells(Rows.Count, "C").End(3).Row
    liste = SD.Range("A2:E" & son).Value
    Set dic = CreateObject("scripting.dictionary")
    For x = 1 To UBound(liste, 1)
        aranan = liste(x, 1)
        If Not dic.exists(aranan) Then
            dic.Add aranan, ""
        End If
    Next x
    SO.Range("A2:A" & Rows.Count).ClearContents
    SO.Range("A2").Resize(dic.Count, 1) = Application.Transpose(dic.keys)
End Sub

ilk üç sütunu aktararak üzerinde işlem yapmam gerekiyor.

 

[Orion1]

Örnek dosya yollarsanız fena olmaz.

 

[Ziynettin]

Deneyiniz...

Sub kod_1()
    Dim SD As Worksheet: Set SD = Sheets("Sayfa1")
    Dim SO As Worksheet: Set SO = Sheets("Sayfa2")
    Dim liste(), dizi(), b()
    son = SD.Cells(Rows.Count, "C").End(3).Row
    liste = SD.Range("A2:C" & son).Value
    Set dic = CreateObject("scripting.dictionary")
    For x = 1 To UBound(liste, 1)
        aranan = liste(x, 1) & liste(x, 2) & liste(x, 3)
        If Not dic.exists(aranan) Then
            dic(aranan) = dic.Count + 1
            say = dic.Count
            ReDim Preserve b(1 To 3, 1 To say)
            For j = 1 To 3
                b(j, say) = liste(x, j)
            Next j
        End If
    Next x
    SO.Range("A2:A" & Rows.Count).ClearContents
    SO.Range("A2").Resize(dic.Count, 3) = Application.Transpose(b)
    MsgBox "İşlem tamam.", vbInformation
End Sub

 

[igultekin2000]

Deneyiniz...

Sub kod_1()
    Dim SD As Worksheet: Set SD = Sheets("Sayfa1")
    Dim SO As Worksheet: Set SO = Sheets("Sayfa2")
    Dim liste(), dizi(), b()
    son = SD.Cells(Rows.Count, "C").End(3).Row
    liste = SD.Range("A2:C" & son).Value
    Set dic = CreateObject("scripting.dictionary")
    For x = 1 To UBound(liste, 1)
        aranan = liste(x, 1) & liste(x, 2) & liste(x, 3)
        If Not dic.exists(aranan) Then
            dic(aranan) = dic.Count + 1
            say = dic.Count
            ReDim Preserve b(1 To 3, 1 To say)
            For j = 1 To 3
                b(j, say) = liste(x, j)
            Next j
        End If
    Next x
    SO.Range("A2:A" & Rows.Count).ClearContents
    SO.Range("A2").Resize(dic.Count, 3) = Application.Transpose(b)
    MsgBox "İşlem tamam.", vbInformation
End Sub

Teşekkürler sorunsuz çalışıyor