ş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