Aynı Satırları Sutunda Birleştirmek

[xtrkax]

Merhabalar,

Alt alta her satırda son sutun hariç hepsi aynı tekrar bir listem var. Son sutun hariç veriler aynı ve alt alta listeli durumda.
İstediğim şey satırların tek sıra olup son sutunların yan yana listelenmesi.

Yani şu an bu şekilde:



Fakat şöyle olsun istiyorum:



Nasıl mümkün kılabilirim? Örnek dosyayı paylaştım.

 

[EmrExcel16]

Deneyiniz..

Sub Test()
    Dim i, bul, OncAdrs
    Application.ScreenUpdating = False
    Range("J2:AA100000").ClearContents
    Range("J2:M" & Cells(Rows.Count, 1).End(3).Row).Value = Range("A2:D" & Cells(Rows.Count, 1).End(3).Row).Value
    Range("J2:M" & Cells(Rows.Count, 1).End(3).Row).RemoveDuplicates Columns:=4
    For i = 2 To Cells(Rows.Count, 10).End(3).Row
        Set bul = Range("A2:A100000").Find(Cells(i, 10), , xlValues, xlWhole)
        If Not bul Is Nothing Then
            OncAdrs = bul.Address
            Do
                Cells(i, Cells(i, Columns.Count).End(1).Column + 1) = Cells(bul.Row, 5)
                Set bul = Range("A2:A100000").FindNext(bul)
            Loop While Not bul Is Nothing And bul.Address <> OncAdrs
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "Islem Tamam..."
End Sub

 

[xtrkax]

Deneyiniz..

Sub Test()
    Dim i, bul, OncAdrs
    Application.ScreenUpdating = False
    Range("J2:AA100000").ClearContents
    Range("J2:M" & Cells(Rows.Count, 1).End(3).Row).Value = Range("A2:D" & Cells(Rows.Count, 1).End(3).Row).Value
    Range("J2:M" & Cells(Rows.Count, 1).End(3).Row).RemoveDuplicates Columns:=4
    For i = 2 To Cells(Rows.Count, 10).End(3).Row
        Set bul = Range("A2:A100000").Find(Cells(i, 10), , xlValues, xlWhole)
        If Not bul Is Nothing Then
            OncAdrs = bul.Address
            Do
                Cells(i, Cells(i, Columns.Count).End(1).Column + 1) = Cells(bul.Row, 5)
                Set bul = Range("A2:A100000").FindNext(bul)
            Loop While Not bul Is Nothing And bul.Address <> OncAdrs
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "Islem Tamam..."
End Sub

İşimi gördü hocam çok teşekkür ederim.

 

[EmrExcel16]

İşimi gördü hocam çok teşekkür ederim.

Rica ederim , iyi çalışmalar .

 

[YUSUF44]

Aşağıdaki makroyu deneyiniz. Verilerinizin çokluğuna göre işlem uzun sürebilir:

Sub duzenle() sonA = Cells(Rows.Count, "A").End(3).Row sonJ = Cells(Rows.Count, "J").End(3).Row sonsut = [J1].SpecialCells(xlLastCell).Column Range(Cells(3, "J"), Cells(sonJ, sonsut)).ClearContents Range("A3:D" & sonA).Copy [J3] Range("J2:M" & sonA).RemoveDuplicates Columns:=Array(1, 2, 3), _ Header:=xlYes Application.CutCopyMode = False sonJ = Cells(Rows.Count, "J").End(3).Row Application.ScreenUpdating = False For j = 3 To sonJ For i = 3 To sonA If Cells(i, "A") = Cells(j, "J") And Cells(i, "B") = Cells(j, "K") And _ Cells(i, "C") = Cells(j, "L") And Cells(i, "D") = Cells(j, "M") Then yeni = Cells(j, Columns.Count).End(xlToLeft).Column + 1 Cells(j, yeni) = Cells(i, "E") End If Next Next Application.ScreenUpdating = True MsgBox "İşlem tamamlandı." End Sub