stok koduna göre toparlama

[newmaster]

1nci ve 4ncü sütunlarda mükerrerlik arandı ve son tarihli satırlar listelendi.
Dosya ektedir.

Son bir sorum olacak, E sütununa da bir yazı yazsam koddan nereyi değiştirmem lazım renklendirerek belirtirmisiniz bu sayede bende ögrenmiş olurum Teşekkür ederim herşey için.

Option Base 1
Sub listele59()
Dim sh As Worksheet, z As Object, liste, myarr, i As Long
Dim sonsat As Long, n As Long
Sheets("Sayfa1").Select
sonsat = Cells(Rows.Count, "D").End(xlUp).Row
Application.ScreenUpdating = False
Range("A2:D" & sonsat).Sort key1:=Range("A2"), order1:=xlAscending, _
        key2:=Range("D2"), order2:=xlAscending, _
        key3:=Range("B2"), order3:=xlAscending
Set sh = Sheets("Rapor")
sh.Range("A2:D" & Rows.Count).ClearContents
liste = Range("A2:D" & sonsat).Value
ReDim myarr(1 To 4, 1 To sonsat)
Set z = CreateObject("Scripting.dictionary")
For i = 1 To UBound(liste)
    If Not z.exists(liste(i, 1) & liste(i, 4)) Then
        n = n + 1
        z.Add liste(i, 1) & liste(i, 4), n
        myarr(1, n) = liste(i, 1)
        myarr(4, n) = liste(i, 4)
    End If
    myarr(2, z.Item(liste(i, 1) & liste(i, 4))) = liste(i, 2)
    myarr(3, z.Item(liste(i, 1) & liste(i, 4))) = liste(i, 3)
Next i
Erase liste
ReDim Preserve myarr(1 To 4, 1 To z.Count)
If z.Count > 0 Then sh.Range("A2").Resize(z.Count, 4) = Application.Transpose(myarr)
Erase myarr: Set z = Nothing
Application.ScreenUpdating = True
sh.Select
Set sh = Nothing
MsgBox "Benzersiz veriler yakın tarihe göre aktarıldı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[Orion1]

Son bir sorum olacak, E sütununa da bir yazı yazsam koddan nereyi değiştirmem lazım renklendirerek belirtirmisiniz bu sayede bende ögrenmiş olurum Teşekkür ederim herşey için.

Buyurun.

Option Base 1
Sub listele59()
Dim sh As Worksheet, z As Object, liste, myarr, i As Long
Dim sonsat As Long, n As Long
Sheets("Sayfa1").Select
sonsat = Cells(Rows.Count, "D").End(xlUp).Row
Application.ScreenUpdating = False
Range("A2:[B][COLOR="Red"]E[/COLOR][/B]" & sonsat).Sort key1:=Range("A2"), order1:=xlAscending, _
        key2:=Range("D2"), order2:=xlAscending, _
        key3:=Range("B2"), order3:=xlAscending
Set sh = Sheets("Rapor")
sh.Range("A2:[B][COLOR="red"]E[/COLOR][/B]" & Rows.Count).ClearContents
liste = Range("A2:[B][COLOR="red"]E[/COLOR][/B]" & sonsat).Value
ReDim myarr(1 To [B][COLOR="red"]5[/COLOR][/B], 1 To sonsat)
Set z = CreateObject("Scripting.dictionary")
For i = 1 To UBound(liste)
    If Not z.exists(liste(i, 1) & liste(i, 4)) Then
        n = n + 1
        z.Add liste(i, 1) & liste(i, 4), n
        myarr(1, n) = liste(i, 1)
        myarr(4, n) = liste(i, 4)
        [B][COLOR="red"]myarr(5, n) = liste(i, 5)[/COLOR][/B]
    End If
    myarr(2, z.Item(liste(i, 1) & liste(i, 4))) = liste(i, 2)
    myarr(3, z.Item(liste(i, 1) & liste(i, 4))) = liste(i, 3)
Next i
Erase liste
ReDim Preserve myarr(1 To [B][COLOR="Red"]5[/COLOR][/B], 1 To z.Count)
If z.Count > 0 Then sh.Range("A2").Resize(z.Count, [B][COLOR="red"]5[/COLOR][/B]) = Application.Transpose(myarr)
Erase myarr: Set z = Nothing
Application.ScreenUpdating = True
sh.Select
Set sh = Nothing
MsgBox "Benzersiz veriler yakın tarihe göre aktarıldı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[Orion1]

Levent bey c sutunu için verdiğin numarayı b sunutu olarak değiştirdim şimdi oldu çok teşekkür ederim ilginiz için

Rica ederim.
İyi çalışmalar.
Not: İsmim Levent değil,Evren.