Mükerrer Olanları Teke Düşürüp Şarta Göre Diğer Sayfaya Aktarma

[manly]

Ekte gönderdiğim dosyanın VERİ sayfasındaki A ve B sütunlarındaki verileri eşit olan satırlar teke düşürülüp D ve E sütunları toplanacak.
Daha sonra A sütunundaki Sipariş No değeri Keşif sayfasının A sütununda bulunup o satırın S sütunundan başlamak kaydı ile Veri sayfasındaki veriler aktarılacak

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub Ozet_Topla_Aktar()
 
    Dim d As Object, i As Long, j As Byte, s, a1, deg, c As Range, sut As Integer

    Set d = CreateObject("Scripting.Dictionary")

    Application.ScreenUpdating = False
    Sheets("Veri").Select

    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        deg = Cells(i, "A") & "|" & Cells(i, "B")
        If Not d.exists(deg) Then
            ReDim s(1 To 6)
            For j = 1 To 6
                s(j) = Cells(i, j)
            Next j
            d.Add deg, s
        Else
            s = d.Item(deg)
            For j = 4 To 5
                s(j) = s(j) + Cells(i, j)
            Next j
            d.Item(deg) = s
        End If
    Next i

    Sheets("Kesif").Select
    Range(Cells(2, "S"), Cells(Rows.Count, Columns.Count)).ClearContents
    
    a1 = d.items
    For i = 0 To d.Count - 1
        s = a1(i)
        Set c = [A:A].Find(s(1), , xlValues, xlWhole)
        If Not c Is Nothing Then
            sut = Application.Max(17, Cells(c.Row, Columns.Count).End(xlToLeft).Column - 1)
            For j = 2 To 6
                Cells(c.Row, sut + j) = s(j)
            Next j
        End If
    Next i

    Application.ScreenUpdating = True

End Sub

.

 

[manly]

Teşekkürler Ömer hocam...