Dolgulu Tekrarlı Hücreleri Birleştirme

[ismail-34]

Çok Değerli Excel Web Hocalarına selamlar saygılar..

Benim naçizane sorum, bir projemde kullanmak üzere, tekrarlı olan hücreleri birleştirmek ile ilgili..

Dosyam linktedir.

İndir tekrarlı hücreleri birleştirme xlsx

Dosyayı indir tekrarlı hücreleri birleştirme xlsx

dosya.co

Yardımcı olursanız çok sevinirim..

 

[veyselemre]

Sub test()
    Dim sV As Worksheet, sS As Worksheet, i&, krt$, sSat&, say&, sira&
    Set sV = Sheets("veri")
    sSat = sV.Cells(Rows.Count, 2).End(3).Row
    ReDim liste(1 To sSat, 1 To 8)

    With CreateObject("Scripting.Dictionary")
        For i = 3 To sSat
            If sV.Cells(i, 2).Interior.Color = vbRed Then
                krt = sV.Cells(i, 3).Value
                If .exists(krt) Then
                    sira = .Item(krt)
                    liste(sira, 2) = liste(sira, 2) & " + " & sV.Cells(i, 2).Value
                    liste(sira, 8) = liste(sira, 8) + sV.Cells(i, 8).Value
                Else
                    say = say + 1
                    liste(say, 1) = say
                    liste(say, 2) = sV.Cells(i, 2).Value
                    liste(say, 3) = sV.Cells(i, 3).Value
                    liste(say, 8) = sV.Cells(i, 8).Value
                    .Item(krt) = say
                End If
            End If
        Next i
    End With
    With Sheets("sonuç")
        .Range("A3:H" & Rows.Count).ClearContents
        With .Range("A3:H4").Resize(say)
            .Value = liste
            .Columns(8).NumberFormat = ("#,##0.00 \$;-#,##0.00 \$")
        End With
    End With
End Sub

 

[ismail-34]

Sub test()
    Dim sV As Worksheet, sS As Worksheet, i&, krt$, sSat&, say&, sira&
    Set sV = Sheets("veri")
    sSat = sV.Cells(Rows.Count, 2).End(3).Row
    ReDim liste(1 To sSat, 1 To 8)

    With CreateObject("Scripting.Dictionary")
        For i = 3 To sSat
            If sV.Cells(i, 2).Interior.Color = vbRed Then
                krt = sV.Cells(i, 3).Value
                If .exists(krt) Then
                    sira = .Item(krt)
                    liste(sira, 2) = liste(sira, 2) & " + " & sV.Cells(i, 2).Value
                    liste(sira, 8) = liste(sira, 8) + sV.Cells(i, 8).Value
                Else
                    say = say + 1
                    liste(say, 1) = say
                    liste(say, 2) = sV.Cells(i, 2).Value
                    liste(say, 3) = sV.Cells(i, 3).Value
                    liste(say, 8) = sV.Cells(i, 8).Value
                    .Item(krt) = say
                End If
            End If
        Next i
    End With
    With Sheets("sonuç")
        .Range("A3:H" & Rows.Count).ClearContents
        With .Range("A3:H4").Resize(say)
            .Value = liste
            .Columns(8).NumberFormat = ("#,##0.00 \$;-#,##0.00 \$")
        End With
    End With
End Sub

Veysel hocam üyeliğiniz gibi çok özelsiniz.Saat gibi çalışıyor..bu çözümü gördükten sonra mesleği bırakıyorum, bir ipte 2 canbaz oynamaz sağlıcakla kalın ...sağolun varolun harikasınız...