Birden fazla aynı değeri birleştirme

[alemdar1905]

İyi çalışmalar.

Elimde bir excel bulunmakta a sütununda barkod ve b sütununda içerik bilgisi yer almaktadır.. İçerik bilgisi maximum 80 karakter olduğundan satır açıp bir alt satıra devamı yazılmaktadır.(en az 2 ve daha fazla olabilir) barkod aynı şekilde yazılmaktadır.

Benim isteğim böyle veri girişi yapılmış bir excelin barkodları aynı olan içerik bilgilerini birleştirmek ve yan sütuna yazmak aynı olmayanı ise direk yan sütuna yazmak böyle bir makro oluşturabilirmiyiz ?

 

[Ömer]

Merhaba,

Sorunuz net değil, eklediğiniz dosyada olmasını istediğiniz durumu C sütununa siz manuel yazarak açıklayın ve dosyanızı o şekilde ekleyin.

Not: Dosyanızı foruma eklemenizi rica ederim.

Sorunun devamında, ataç eklemek( Dosya eklemek).

.

 

[alemdar1905]

İlginiz için çok teşekkür ederim Örnek excel sayfam istediğiniz şekilde düzenlenmiştir yardımlarınız için şimdiden teşekkür ederim.

 

[alemdar1905]

Arkadaşlar yardımınızı beklemekteyim.. Konu halen aktif durumda yardımcı olursanız sevinirim. İyi çalışmalar.

 

[Ömer]

İlginiz için çok teşekkür ederim Örnek excel sayfam istediğiniz şekilde düzenlenmiştir yardımlarınız için şimdiden teşekkür ederim.

Dosyanız ektedir. Farklı bir sütunda birleştirme yaptırdım. Bu şekilde daha kullanışlı ve derli toplu olur diye düşünüyorum.
Birlestir butonunu kullanın.
.

 

[alemdar1905]

Yardımlarınız için çok teşekkür ederim.. Çok işime yaradı Allah Razı olsun..

 

[angelirde]

Dosyanız ektedir. Farklı bir sütunda birleştirme yaptırdım. Bu şekilde daha kullanışlı ve derli toplu olur diye düşünüyorum.
Birlestir butonunu kullanın.
.

Merhaba,
Sizin yayınladığınız bu excel'e benzer bir excel dosyasına ihtiyaç duymaktayım.
Fakat bir sütunu referans alıp diğer sütunları birleştirirken mükerrer kayıtları teke indirgemesini istiyorum. Ek'te örnek dosya mevcuttur.
Teşekkürler ilginiz için

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub Ozet_Al()
 
    Dim d As Object, i As Long, s, a1, a2, deg
    
    Set d = CreateObject("Scripting.Dictionary")
    
    Application.ScreenUpdating = False
    Range("I2:L" & Rows.Count).ClearContents
    
    For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
        deg = Cells(i, "B")
        If Not d.exists(deg) Then
            s = Array(Cells(i, "C"), Cells(i, "E"), Cells(i, "F"))
            d.Add deg, s
        Else
            s = d.Item(deg)
            If InStr(1, s(1), Cells(i, "E"), vbTextCompare) = 0 Then _
                s(1) = s(1) & ";" & Cells(i, "E")
            If InStr(1, s(2), Cells(i, "F"), vbTextCompare) = 0 Then _
                s(2) = s(2) & ";" & Cells(i, "F")
            d.Item(deg) = s
        End If
    Next i
    
    a1 = d.keys: a2 = d.items
    
    For i = 0 To d.Count - 1
        Cells(i + 2, "I") = a1(i)
        s = a2(i)
        Cells(i + 2, "J") = s(0)
        Cells(i + 2, "K") = s(1)
        Cells(i + 2, "L") = s(2)
    Next i
    
    Columns("I:L").EntireColumn.AutoFit
 
End Sub

 

[angelirde]

Merhabalar, Çok teşekkür ederim