Benzer verileri tek satırda toplamak

[FDUYAR]

Merhaba aşağıdaki resimde olduğu gibi bir tablo var, yardımcı olabilir misiniz.

 

[muygun]

Merhaba;
Örnek dosya ekleyin yada;
Sayfanın kod bölümüne;

Sub analiz()
Application.ScreenUpdating = False
On Error Resume Next
sat = 1
Range("c1:d65536").ClearContents
For i = 1 To Range("A65536").End(xlUp).Row
If WorksheetFunction.CountIf(Range("a1:a" & i), Cells(i, "a")) = 1 Then
Cells(sat, "c") = Cells(i, 1)
sat = sat + 1
End If
Next i
For i = 1 To Range("c65536").End(xlUp).Row
For k = 1 To Range("a65536").End(xlUp).Row
If Cells(i, "c") = Cells(k, "a") Then
If Cells(i, "d") <> "" Then
Cells(i, "d") = Cells(i, "d") & ", " & Cells(k, "b")
End If
If Cells(i, "d") = "" Then
Cells(i, "d") = Cells(k, "b")
End If
End If
Next k
Next i
Application.ScreenUpdating = True
MsgBox "İşlem TAMAM.", vbInformation
End Sub

Kodlarını yerleştirin ve bir butona bağlayarak çalıştırın.
İyi çalışmalar.

 

[FDUYAR]

Ben denedim ama olmadı dosya ektedir bide siz dener misiniz.

Ben ilk mesajımda verdiğim resimdeki gibi olması istiyorum.

 

[muygun]

Merhaba;
Eki deneyin.
İyi çalışmalar.

Not: veri çokluğuna ve pc nizin performansına göre işlem uzun sürebilir. İşlem bitti uyarısına kadar bekleyin.
Ayrıca verilerinizin miktarı değişken olabileceğini varsayarak ben verinin altına değil yan tarafta tasnifledim. Gerekli görürseniz kopyala-yapıştır ile istediğiniz alana taşırsınız.

 

[FDUYAR]

yok ben bi türlü yapamadım..

yani sizin verdiğiniz dosyada kodu çalıştırıyorum ama sonuç benim istediğim gibi olmuyor yani ilk mesajımda resimde gösterdiğim şekilde bir sonuç alamıyorum

 

[Ömer BARAN]

Merhaba.

Aşağıdaki kod'u kullanabilirsiniz.
NOT: Gerçek belgedeki verilerinizin de örnek belgedeki gibi 1'inci satırdan başladığını varsaydım.

Sub BARAN()
son = Cells(Rows.Count, 1).End(3).Row
For sat = 1 To son
    If WorksheetFunction.CountIf(Range("A1:A" & sat), Cells(sat, 1)) = 1 Then
        For satt = sat + 1 To son
            If Cells(sat, 1) = Cells(satt, 1) Then
                Cells(sat, 2) = Cells(sat, 2) & ", " & Cells(satt, 2)
                Range("A" & satt & ":B" & satt).Delete Shift:=xlUp
                satt = satt - 1
                If Cells(Rows.Count, 1).End(3).Row = satt Then GoTo 10
            Else: Exit For: End If
        Next: End If: Next
10: Columns("A:B").AutoFit
MsgBox "İşlem tamamlandı.", vbInformation, "..:: Ömer BARAN ::.."
End Sub

 

[FDUYAR]

Merhaba.

Aşağıdaki kod'u kullanabilirsiniz.
NOT: Gerçek belgedeki verilerinizin de örnek belgedeki gibi 1'inci satırdan başladığını varsaydım.

Sub BARAN()
son = Cells(Rows.Count, 1).End(3).Row
For sat = 1 To son
    If WorksheetFunction.CountIf(Range("A1:A" & sat), Cells(sat, 1)) = 1 Then
        For satt = sat + 1 To son
            If Cells(sat, 1) = Cells(satt, 1) Then
                Cells(sat, 2) = Cells(sat, 2) & ", " & Cells(satt, 2)
                Range("A" & satt & ":B" & satt).Delete Shift:=xlUp
                satt = satt - 1
                If Cells(Rows.Count, 1).End(3).Row = satt Then GoTo 10
            Else: Exit For: End If
        Next: End If: Next
10: Columns("A:B").AutoFit
MsgBox "İşlem tamamlandı.", vbInformation, "..:: Ömer BARAN ::.."
End Sub

oldu teşekkürler

 

[Korhan Ayhan]

Alternatif,

Biraz daha hızlı sonuç verir.

"Rapor" isimli sayfada verileriniz listelenir.

Sub Listele()
    Dim S1 As Worksheet, X As Long, Son As Long
    Dim Satir As Long, Son_Satir As Long, Zaman As Double
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Zaman = Timer
    
    Set S1 = Sheets("Sheet1")
    
    S1.Range("C:D").EntireColumn.ClearContents
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Satir = 1
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Rapor").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Sheets.Add
    Set S2 = ActiveSheet
    S2.Name = "Rapor"
    
    For X = 1 To Son
        If S1.Cells(X, 1) <> "" Then
            Son_Satir = Evaluate("=LOOKUP(2,1/('" & S1.Name & "'!A1:A" & Son & "=""" & S1.Cells(X, 1) & """),ROW('" & S1.Name & "'!A1:A" & Son & "))")
            If Son_Satir - X = 0 Then
                S2.Cells(Satir, 1) = S1.Cells(X, 1)
                S2.Cells(Satir, 2) = S1.Cells(X, 2)
            Else
                S2.Cells(Satir, 1) = S1.Cells(X, 1)
                S2.Cells(Satir, 2) = Join(Application.Transpose(S1.Range("B" & X & ":B" & Son_Satir)), ", ")
            End If
            Satir = Satir + 1
            X = Son_Satir
        End If
    Next

    S2.Range("A:B").EntireColumn.AutoFit

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & "İşlem süresi ; " & Format(Timer - Zaman, "0.00000"), vbInformation
End Sub