• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

şartlı birleştirmede sıra

O

oydemir

Altın Üye
Katılım
22 Eylül 2007
Mesajlar
305
Excel Vers. ve Dili
Türkçe 2016
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
 

Ekli dosyalar

Kod: 
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
 
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ü
 
Merhaba,

Tam olarak nasıl bir sonuç görmek istiyorsunuz?
 
teşekkürler Örnek ekledim size zahmet.
 

Ekli dosyalar

Dosyanızda sadece bir sütun dolu... Sanırım hatalı dosya yüklediniz..
 
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
 
Şö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..
 
O zaman bu şekilde bir örnek dosya ekleyiniz. Sütunlar asıl dosyanıza uygun olsun lütfen..
 
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
 

Ekli dosyalar

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.
 
Bu kodu deneyiniz.

C++: 
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
 
Elinize sağlık teşekkür ederim. İyi ki varsınız.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst