Sütundaki belirli bir veriye göre tüm satırı birleştirmek

[YAVUZSs]

Merhabalar;

Elimde şöyle 1 milyon satırlık bir veri var.




ID numaraları aynı olan kişileri; tek bir satırda olacak şekilde birleştirmek istiyorum. Yani olmasını istediğim şekil şöyle;




Bunu nasıl yapabilirim? Elimdeki dosyada satır ve sütun sayıları çok daha fazla ama veriler KVKK kapsamında olduğu için orijinal dosyayı paylaşamıyorum. Yardımcı olabilecek var mıdır acaba? Fonksiyonlarla yapılabilir mi? Yoksa Makro mu kullanmak gerekiyor fikrim yok açıkçası.

Ek kısmına görselini paylaştığım excel'i de ekledim. Şimdiden teşekkürler.

 

[Muzaffer Ali]

Merhaba.

Aşağıdaki kodu bir modüle kopyalayıp çalıştırın.
Not: kod aktif olan sayfada çalışır.

Sub Test()
    Dim Bak As Long
    Application.ScreenUpdating = False
    For Bak = Cells(Rows.Count, "A").End(xlUp).Row To 3 Step -1
        If Cells(Bak, "D") = Cells(Bak - 1, "D") Then
            Cells(Bak - 1, "B") = Cells(Bak - 1, "B") & Chr(10) & Cells(Bak, "B")
            Cells(Bak - 1, "C") = Cells(Bak - 1, "C") & Chr(10) & Cells(Bak, "C")
            Cells(Bak - 1, "D") = Cells(Bak - 1, "D") & Chr(10) & Cells(Bak, "D")
            Rows(Bak).Delete
        End If
    Next
    Application.ScreenUpdating = True
End Sub

 

[YAVUZSs]

Merhaba.

Aşağıdaki kodu bir modüle kopyalayıp çalıştırın.
Not: kod aktif olan sayfada çalışır.

Sub Test()
    Dim Bak As Long
    Application.ScreenUpdating = False
    For Bak = Cells(Rows.Count, "A").End(xlUp).Row To 3 Step -1
        If Cells(Bak, "D") = Cells(Bak - 1, "D") Then
            Cells(Bak - 1, "B") = Cells(Bak - 1, "B") & Chr(10) & Cells(Bak, "B")
            Cells(Bak - 1, "C") = Cells(Bak - 1, "C") & Chr(10) & Cells(Bak, "C")
            Cells(Bak - 1, "D") = Cells(Bak - 1, "D") & Chr(10) & Cells(Bak, "D")
            Rows(Bak).Delete
        End If
    Next
    Application.ScreenUpdating = True
End Sub

Öncelikle çok teşekkür ederim.

Burada tekrarlayan ID sayısı 2 değil de 3-4-5-10-20 olduğunda kodun çalışabilmesi için ne gibi düzenlemeler yapılması gerekiyor acaba?

 

[Muzaffer Ali]

Aşağıdaki kodu deneyin

Sub Test()
    Dim Bak As Long
    Dim Bak2 As Long
    Dim Isim As String
    Dim SoyIsim As String
    Dim ID As String
    Dim SonSatir As Long
    
    Application.ScreenUpdating = False
    For Bak = Cells(Rows.Count, "A").End(xlUp).Row To 3 Step -1
        If Cells(Bak, "D") = Cells(Bak - 1, "D") Then
            For Bak2 = Bak To 3 Step -1
                If Cells(Bak2, "D") = Cells(Bak2 - 1, "D") Then
                    If Isim = "" Then
                        Isim = Cells(Bak2, "B")
                        SoyIsim = Cells(Bak2, "C")
                        ID = Cells(Bak2, "D")
                    Else
                        Isim = Cells(Bak2, "B") & Chr(10) & Isim
                        SoyIsim = Cells(Bak2, "C") & Chr(10) & SoyIsim
                        ID = Cells(Bak2, "D") & Chr(10) & ID
                    End If
                    Rows(Bak2).Delete
                Else
                    Cells(Bak2, "B") = Cells(Bak2, "B") & Chr(10) & Isim
                    Cells(Bak2, "C") = Cells(Bak2, "C") & Chr(10) & SoyIsim
                    Cells(Bak2, "D") = Cells(Bak2, "D") & Chr(10) & ID
                    Isim = ""
                    SoyIsim = ""
                    ID = ""
                    Exit For
                End If
            Next
        End If
    Next
    
    Range("A4") = 2
    SonSatir = Cells(Rows.Count, "A").End(xlUp).Row
    Range("A3:A" & SonSatir - 1).AutoFill Destination:=Range("A3:A" & SonSatir)
    Application.ScreenUpdating = True
End Sub

 

[YAVUZSs]

Aşağıdaki kodu deneyin

Sub Test()
    Dim Bak As Long
    Dim Bak2 As Long
    Dim Isim As String
    Dim SoyIsim As String
    Dim ID As String
    Dim SonSatir As Long
   
    Application.ScreenUpdating = False
    For Bak = Cells(Rows.Count, "A").End(xlUp).Row To 3 Step -1
        If Cells(Bak, "D") = Cells(Bak - 1, "D") Then
            For Bak2 = Bak To 3 Step -1
                If Cells(Bak2, "D") = Cells(Bak2 - 1, "D") Then
                    If Isim = "" Then
                        Isim = Cells(Bak2, "B")
                        SoyIsim = Cells(Bak2, "C")
                        ID = Cells(Bak2, "D")
                    Else
                        Isim = Cells(Bak2, "B") & Chr(10) & Isim
                        SoyIsim = Cells(Bak2, "C") & Chr(10) & SoyIsim
                        ID = Cells(Bak2, "D") & Chr(10) & ID
                    End If
                    Rows(Bak2).Delete
                Else
                    Cells(Bak2, "B") = Cells(Bak2, "B") & Chr(10) & Isim
                    Cells(Bak2, "C") = Cells(Bak2, "C") & Chr(10) & SoyIsim
                    Cells(Bak2, "D") = Cells(Bak2, "D") & Chr(10) & ID
                    Isim = ""
                    SoyIsim = ""
                    ID = ""
                    Exit For
                End If
            Next
        End If
    Next
   
    Range("A4") = 2
    SonSatir = Cells(Rows.Count, "A").End(xlUp).Row
    Range("A3:A" & SonSatir - 1).AutoFill Destination:=Range("A3:A" & SonSatir)
    Application.ScreenUpdating = True
End Sub

Çok teşekkür ediyorum.