şartlı birleştirmede sıra

[oydemir]

Sayın Veysel emre beyin yazdığı kodu kullanıyorum gayet güzel bir şekilde çalışıyor fakat veriler sıralı olmayınca verileri birleştirmiyor. B sütunundaki değerler aynı ise e sütunundaki verileri birleştir H sütununa yazmakta.

Fakat veriler sıralı olmayınca b sütunundaki verileri birleştirmiyor buna çözüm bulana bilinir mi?

Sub işlem()
Dim son&
Range("H2:H" & Rows.Count).ClearContents
son = Range("B" & Rows.Count).End(xlUp).Row
With CreateObject("Scripting.Dictionary")
For i = 2 To son
If Cells(i, "B").Value = Cells(i , "B").Value Then
.RemoveAll
For ii = i To son
If Cells(i, "B").Value = Cells(ii, "B").Value Then
.Item(Cells(ii, "E").Value) = Null
Else
Exit For
End If
Next ii
Cells(i, "H").Resize(ii - i).Value = Join(.keys, " ")
i = ii - 1
Else
Cells(i, "H").Value = Cells(i, "B").Value
End If
Next i
End With
MsgBox "İşlem TAMAM.", vbInformation
End Sub



Sub işlem()
Dim son&
Range("H2:H" & Rows.Count).ClearContents
son = Range("B" & Rows.Count).End(xlUp).Row
With CreateObject("Scripting.Dictionary")
For i = 2 To son
If Cells(i, "B").Value = Cells(i + 1, "B").Value Then
.RemoveAll
For ii = i To son
If Cells(i, "B").Value = Cells(ii, "B").Value Then
.Item(Cells(ii, "E").Value) = Null
Else
Exit For
End If
Next ii
Cells(i, "H").Resize(ii - i).Value = Join(.keys, " ")
i = ii - 1
Else
Cells(i, "H").Value = Cells(i, "B").Value
End If
Next i
End With
MsgBox "İşlem TAMAM.", vbInformation
End Sub

 

[veyselemre]

Sub işlem()
    Dim son&, veri
    Range("H1:H" & Rows.Count).ClearContents
    son = Range("B" & Rows.Count).End(xlUp).Row
    veri = Range("B1:E" & son).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(veri)
            .Item(veri(i, 1)) = .Item(veri(i, 1)) & "," & veri(i, 4)
        Next i
        For i = 1 To UBound(veri)
            veri(i, 1) = Mid(.Item(veri(i, 1)), 2)
        Next i
        For i = 1 To UBound(veri)
            .RemoveAll
            For Each elem In Split(veri(i, 1), ",")
                If elem <> "" Then .Item(elem) = Null
            Next elem
            veri(i, 1) = Join(.keys)
        Next i
        Range("H1:H" & son).Value = veri
    End With
    MsgBox "İşlem TAMAM.", vbInformation
End Sub

 

[oydemir]

Elinize sağlık teşekkürler çok işimi gördünüz

 

[oydemir]

Sayın
veyselemre bey
Kod gayet güzel çalışmakta fakat bir sorun oluştu. Aynı olan değerleri yeni kolona bir tanesini yazdırması mümkün mü

 

[Korhan Ayhan]

Merhaba,

Tam olarak nasıl bir sonuç görmek istiyorsunuz?

 

[oydemir]

teşekkürler Örnek ekledim size zahmet.

 

[Korhan Ayhan]

Dosyanızda sadece bir sütun dolu... Sanırım hatalı dosya yüklediniz..

 

[oydemir]

Evet kusura bakmayın yenisini yükledim.

 

[oydemir]

a kolonundaki değerler aynı ise c kolonuna b kolonundaki değerleri toplayıp yazacak. Bunu veyselemre beyin kodları yapıyor. Fakat b kolonundaki değerleri her defasında yazıyor. yani örnekteki b2 hücresindeki değer( Eski 2933 2932 Eski Oluştu. var ) c kolonuna tekrar tekrar yazmış oluyor .
benim isteğim tekrar düşmeden c kolonuna yazması. Teşekkürler

 

[Korhan Ayhan]

Şöyle yapsanız daha anlaşılır olmaz mı?

Kod çalışınca oluşan sonuçlar B sütununda olsun. Sizin görmek istediğiniz sonuçlar ise C sütununda olsun..

 

[oydemir]

evet

 

[Korhan Ayhan]

O zaman bu şekilde bir örnek dosya ekleyiniz. Sütunlar asıl dosyanıza uygun olsun lütfen..

 

[oydemir]

Korhan hocam teşekkürler, en baştaki kodları kullanarak c kolonuna değerleri toplayıp aşağıdaki kodla tek yaptım fakat doğruluğuna emin olamadım. İlginize teşekkür ederim.
Sub Duzenle()

Dim i As Long
Dim j As Integer
Dim arr As Variant
Dim col As Integer
Dim t As Variant

col = Cells(1, Columns.Count).End(1).Column + 1
Application.ScreenUpdating = False

For i = 2 To Cells(Rows.Count, "c").End(3).Row
arr = Split(Cells(i, "c"), " ")
Cells(1, col).Resize(UBound(arr) + 1, 1) = Application.WorksheetFunction.Transpose(arr)
j = Cells(Rows.Count, col).End(3).Row
Range(Cells(1, col), Cells(j, col)).RemoveDuplicates Columns:=1, Header:=xlNo
j = Cells(Rows.Count, col).End(3).Row
Range(Cells(1, col), Cells(j, col)).Sort Key1:=Cells(1, col)
t = Application.Transpose(Range(Cells(1, col), Cells(j, col)))
Cells(i, "c") = Join(t, " ")
Next i

Columns(col).ClearContents
Application.ScreenUpdating = True
MsgBox "İşlem Tamamdır...."

End Sub

 

[Korhan Ayhan]

Ben paylaştığınız dosyada kodu denedim. Bir değişiklik göremedim.

Aslında yapmanız gereken basit bir işlem. Varolan verilerden şu sonucu elde etmek istiyorum diye dosyanız üzerinde örneklendirirseniz sonuç almanız kolaylaşır.

 

[oydemir]

Size de Zahmet verdim kusuru bakmayın.

 

[Korhan Ayhan]

Bu kodu deneyiniz.

Sub Unique_Concatenate()
    Dim i&, son&, kisa$, grup, d As Object, liste As Object, item, fark, sonuc$
    
    Set d = CreateObject("Scripting.Dictionary")
    son = Cells(Rows.Count, "A").End(xlUp).Row
    
    ' Grupla
    For i = 2 To son
        If Trim(Cells(i, 1).value) <> "" And Trim(Cells(i, 2).value) <> "" Then
            If Not d.exists(Cells(i, 1).value) Then
                Set d(Cells(i, 1).value) = CreateObject("Scripting.Dictionary")
            End If
            d(Cells(i, 1).value)(Cells(i, 2).value) = True
        End If
    Next
    
    ' Yazdır
    For i = 2 To son
        grup = d(Cells(i, 1).value).keys
        Set liste = CreateObject("Scripting.Dictionary")
        
        ' En kısa ifadeyi bul
        kisa = grup(0)
        For Each item In grup
            If Len(item) < Len(kisa) Then kisa = item
        Next
        liste(kisa) = True
        
        ' Farklı kısımları ekle
        For Each item In grup
            If item <> kisa Then
                If Left(item, Len(kisa)) = kisa Then
                    fark = Mid(item, Len(kisa) + 1)
                    If fark <> "" Then liste(fark) = True
                Else
                    liste(item) = True
                End If
            End If
        Next
        
        ' Sonucu yaz
        sonuc = Join(liste.keys, "")
        Cells(i, 3).value = sonuc
    Next

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[oydemir]

Elinize sağlık teşekkür ederim. İyi ki varsınız.