Tekrarlanan değerleri bulup, kopyalama

[kahramang1]

https://drive.google.com/file/d/0B7rifb6G0ZlISTdZUlBmWlZNMGc/view?usp=sharing
Merhabalar. Yukarıdaki örnekte "E" sütununda tekrarlanan değerleri bulup, satırı yandaki sütuna kopyalamasını sağlayabilir miyiz. Dosya içinde de istediklerime dair örnek var. Teşekkürler.

 

[YUSUF44]

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz:

Sub mükerrer()
son = Cells(Rows.Count, "E").End(3).Row
[A1:E1].Copy [G1]
For i = 2 To son
    If WorksheetFunction.CountIf(Range("E2:E" & son), Cells(i, "E")) > 1 And _
        WorksheetFunction.CountIf(Range("E2:E" & i), Cells(i, "E")) = 1 Then
        yeni = Cells(Rows.Count, "G").End(3).Row + 1
        Range(Cells(i, "A"), Cells(i, "E")).Copy Cells(yeni, "G")
            For j = i + 1 To son
                If Cells(j, "E") = Cells(i, "E") Then
                    yenitekrar = Cells(Rows.Count, "G").End(3).Row + 1
                    Range(Cells(j, "A"), Cells(j, "E")).Copy Cells(yenitekrar, "G")
                End If
            Next
    End If
Next

For k = yenitekrar To 2 Step -1
    If Cells(k, "K") <> Cells(k + 1, "K") Then
        Range(Cells(k + 1, "g"), Cells(k + 1, "K")).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    End If
Next

End Sub

 

[kahramang1]

Çok teşekkürler Yusuf hocam. Tam istediğim gibi olmuş. Yukarıdaki örneği silip, kopyalanan değerleri G1 den başlatacak olsam, nereyi değiştirmem gerekir. Kolay gelsin.

 

[kahramang1]

Örnek satırları silip, verilen kodun hesapladığı değerleri yukarı çekince kod çalışmaz oldu Yusuf hocam. Sebebi ne olabilir? G1 den itibaren başlasın istemiştim.

 

[YUSUF44]

Aşağıdaki gibi deneyin:

Sub mükerrer()
son = Cells(Rows.Count, "E").End(3).Row
For i = 2 To son
    If WorksheetFunction.CountIf(Range("E2:E" & son), Cells(i, "E")) > 1 And _
        WorksheetFunction.CountIf(Range("E2:E" & i), Cells(i, "E")) = 1 Then
        yeni = Cells(Rows.Count, "G").End(3).Row + 1
        If [G1] = "" Then yeni = 1
        Range(Cells(i, "A"), Cells(i, "E")).Copy Cells(yeni, "G")
            For j = i + 1 To son
                If Cells(j, "E") = Cells(i, "E") Then
                    yenitekrar = Cells(Rows.Count, "G").End(3).Row + 1
                    Range(Cells(j, "A"), Cells(j, "E")).Copy Cells(yenitekrar, "G")
                End If
            Next
    End If
Next

For k = yenitekrar To 2 Step -1
    If Cells(k, "K") <> Cells(k + 1, "K") Then
        Range(Cells(k + 1, "g"), Cells(k + 1, "K")).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    End If
Next

End Sub

 

[kahramang1]

Teşekkürler. KOlay gelsin.