Satırdaki Bilgileri Kişiye Göre Birleştirme

[ozkanweb]

Merhaba Değerli Arkadaşlar,

Bir konuda yüksek bilgilerinizi rica ediyorum.
Ekli dosyadaki örnekte olduğu gibi T.C. kimlik no ile kişiler var. Bazı kişilerden bir tane bazı kişilerden 5 veya 10 tane var. İstediğimiz şu; 10 tane kişinin tüm satırlardaki bilgilerini toplayıp bir satıra yazmasını istiyoruz. Ekli dosyada istenilen sonuçta örneklendirilmiştir.

Desteklerinizi rica ederiz.

 

[Ömer BARAN]

Merhaba.

Belgenize, BİRLEŞİK adını vereceğiniz yeni bir sayfa ekleyip aşağıdaki kod'u çalıştırın.
.

[B][COLOR="Red"]Sub BIRLESTIR()[/COLOR][/B]
Set s = Sheets("Sayfa1"): Set b = Sheets("[B][COLOR="Blue"]BİRLEŞİK[/COLOR][/B]")
b.[A1] = "TC KİMLİK NO": b.[B1] = "BİRLEŞEN BİLGİ"
b.Range("A1:B" & b.Cells(Rows.Count, 1).End(3).Row).Borders.LineStyle = xlNone
If b.Cells(Rows.Count, 1).End(3).Row > 1 Then b.Range("A2:B" & Rows.Count).ClearContents
b.[B:B].Font.Size = 9: b.Columns("A:B").VerticalAlignment = xlCenter
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
For ssat = 2 To s.Cells(Rows.Count, 1).End(3).Row
    If WorksheetFunction.CountIf(s.Range("A2:A" & ssat), s.Cells(ssat, 1)) = 1 Then
        bsat = b.Cells(Rows.Count, 1).End(3).Row + 1
        b.Cells(bsat, 1) = s.Cells(ssat, 1)
        For ssat2 = ssat To s.Cells(Rows.Count, 1).End(3).Row
[COLOR="red"]            If s.Cells(ssat, 1) = s.Cells(ssat2, 1) Then[/COLOR]
                metin = metin & Chr(10) & _
                    s.Cells(1, 2) & ":" & s.Cells(ssat2, 2) & " - " & _
                    s.Cells(1, 3) & ":" & s.Cells(ssat2, 3) & " - " & _
                    s.Cells(1, 4) & ":" & s.Cells(ssat2, 4) & " - " & _
                    s.Cells(1, 5) & ":" & s.Cells(ssat2, 5) & " - " & _
                    s.Cells(1, 6) & ":" & s.Cells(ssat2, 6) & " - " & _
                    s.Cells(1, 7) & ":" & s.Cells(ssat2, 7)
[COLOR="Red"]            End If[/COLOR]
        Next
        b.Cells(bsat, 2) = Mid(metin, 2, Len(metin) - 1): metin = ""
    End If
Next
b.Columns("B:B").ColumnWidth = 142.14
b.Columns("B:B").EntireColumn.AutoFit
b.Rows.AutoFit
b.Range("A1:B" & b.Cells(Rows.Count, 1).End(3).Row).Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
b.Activate: MsgBox "İŞLEM TAMAMLANDI", vbInformation, "..:: Ömer BARAN ::.."
[B][COLOR="red"]End Sub[/COLOR][/B]

 

[ozkanweb]

Çok çok çok teşekkür ederiz. Kusursuz ve tam istediğimiz gibi çalışıyor. Ellerinize emeğinize sağlık Ömer Bey. Saygılar.

 

[Ömer BARAN]

Çok çok çok teşekkür ederiz. Kusursuz ve tam istediğimiz gibi çalışıyor. Ellerinize emeğinize sağlık Ömer Bey. Saygılar.

.
Kolay gelsin.
.

 

[tahsinanarat]

Sn. Ömer Hocam, 12345678910 'e ait 6 satır bilgi olmasına rağmen 15 satır gibi bilgi birleştiriyor, diğerleri de aynı. Bakabilirmisiniz.

 

[Ömer BARAN]

Merhaba Tahsin Bey.
Baktım ve kırmızı renklendirdiğim iki satırı ekleyerek önceki cevabımı güncelledim.

Safayı yenileyerek önceki cevabımı kontrol edin.
Kod'un yeni halini kullanabilirsiniz.
.

 

[tahsinanarat]

Elinize sağlık Ömer Hocam, şimdi oldu. Teşekkürler