Veriler ile Sıralama Yapıp İşlem Yapmak

[Protector24]

Merhaba herkese iyi forumlar öncelikle aşağıdaki gibi elimde 8094 kalem veri var. Bu verilerin birçoğu aşağıda açıklayacağım gibidir.

AAA firması - Numara - Miktar - Net Fiyat (A-B-C-D sütunları)

Sorun şu veri çok olduğundan manuel silemiyorum. Aynı numaraya sahip birçok veri var benim istediğim tam olarak şu. Öyle bir şey olsun ki aynı numaraya sahip satırdaki verilerden en üstteki kalsın altındakiler silinsin ve o silinmeyen satırda miktar ve net fiyat toplam olarak yazsın.

Öncesi
x - 6525 - 50 - 100
x - 6525 - 20 - 40
x - 6525 - 10 - 20

Sonrası
x - 6525 - 80 - 160

Teşekkürler.

 

[veyselemre]

Kontrol olarak sadece Numara mı esas alınacak, yoksa firma ve numara ikisi de göz önüne alınacak

 

[Protector24]

Kontrol olarak sadece Numara mı esas alınacak, yoksa firma ve numara ikisi de göz önüne alınacak

Sadece numara esas alınacak. Geri dönüşünüz için teşekkür ederim.

 

[Orion1]

Dosyanız ektedir.

Merhaba herkese iyi forumlar öncelikle aşağıdaki gibi elimde 8094 kalem veri var. Bu verilerin birçoğu aşağıda açıklayacağım gibidir.

AAA firması - Numara - Miktar - Net Fiyat (A-B-C-D sütunları)

Sorun şu veri çok olduğundan manuel silemiyorum. Aynı numaraya sahip birçok veri var benim istediğim tam olarak şu. Öyle bir şey olsun ki aynı numaraya sahip satırdaki verilerden en üstteki kalsın altındakiler silinsin ve o silinmeyen satırda miktar ve net fiyat toplam olarak yazsın.

Öncesi
x - 6525 - 50 - 100
x - 6525 - 20 - 40
x - 6525 - 10 - 20

Sonrası
x - 6525 - 80 - 160

Teşekkürler.

Dosyanız linktedir.

DOSYAYI INDIR

Option Base 1
Sub aktar59()
Dim sh As Worksheet, sonsat As Long, myarr(), liste()
Dim deg As String, z As Object, a As Long, i As Long
Sheets("Sayfa1").Select
Set sh = Sheets("Sayfa2")
Set z = CreateObject("Scripting.dictionary")
sonsat = Cells(Rows.Count, "A").End(xlUp).Row
sh.Range("A2:D" & Rows.Count).ClearContents
ReDim myarr(1 To 4, 1 To sonsat)
liste = Range("A2:D" & sonsat).Value
For i = 1 To UBound(liste)
    deg = liste(i, 1) & liste(i, 2)
    If Not z.exists(deg) Then
        a = a + 1
        z.Add deg, a
        myarr(1, a) = liste(i, 1)
        myarr(2, a) = liste(i, 2)
    End If
    myarr(3, z.Item(deg)) = myarr(3, z.Item(deg)) + liste(i, 3)
    myarr(4, z.Item(deg)) = myarr(4, z.Item(deg)) + liste(i, 4)
Next i
Erase liste
Set z = Nothing
ReDim Preserve myarr(1 To 4, 1 To a)
sh.Select
Range("A2").Resize(a, 4) = Application.Transpose(myarr)
Erase myarr
MsgBox "İşlem Tamamlandı."
End Sub

 

[veyselemre]

Sub satirlardakiVerileriBirlestir()

    veriler = Range("A2:D" & Cells(Rows.Count, 1).End(3).Row).Value

    With CreateObject("Scripting.Dictionary")

        For i = 1 To UBound(veriler)
            
            anahtar = veriler(i, 2)
'           anahtar = veriler(i, 1) & "|" & veriler(i, 2)
            
            If Not .exists(anahtar) Then
                mx = mx + 1
                .Add anahtar, mx
                veriler(mx, 1) = veriler(i, 1)
                veriler(mx, 2) = veriler(i, 2)
                veriler(mx, 3) = veriler(i, 3)
                veriler(mx, 4) = veriler(i, 4)
            Else
                sat = .Item(anahtar)
                veriler(sat, 3) = veriler(sat, 3) + veriler(i, 3)
                veriler(sat, 4) = veriler(sat, 4) + veriler(i, 4)
            End If
        Next i

    End With

    Range("$F$2:" & Cells(Rows.Count, Columns.Count).Address).ClearContents
    Range("F2").Resize(mx, 4).Value = veriler

End Sub

 

[Protector24]

Sub satirlardakiVerileriBirlestir()

    Set dic = CreateObject("Scripting.Dictionary")
    veriler = Range("A2:D" & Cells(Rows.Count, 1).End(3).Row).Value

    With dic

        For i = 1 To UBound(veriler)
           
            anahtar = veriler(i, 2)
'           anahtar = veriler(i, 1) & "|" & veriler(i, 2)
           
            If Not .exists(anahtar) Then
                mx = mx + 1
                .Add anahtar, mx
                veriler(mx, 1) = veriler(i, 1)
                veriler(mx, 2) = veriler(i, 2)
                veriler(mx, 3) = veriler(i, 3)
                veriler(mx, 4) = veriler(i, 4)
            Else
                sat = .Item(anahtar)
                veriler(sat, 3) = veriler(sat, 3) + veriler(i, 3)
                veriler(sat, 4) = veriler(sat, 4) + veriler(i, 4)
            End If
        Next i

    End With

    Range("$F$2:" & Cells(Rows.Count, Columns.Count).Address).ClearContents
    Range("F2").Resize(mx, 4).Value = veriler

    Set dic = Nothing

End Sub

Yardımlarınız için çok teşekkür ederim. Macroyu ekledim ve oldu. Bu kadar hızlı olması çok garip geldi

İyi Forumlar.

 

[Protector24]

Dosyanız ektedir.

Dosyanız linktedir.

DOSYAYI INDIR

Option Base 1
Sub aktar59()
Dim sh As Worksheet, sonsat As Long, myarr(), liste()
Dim deg As String, z As Object, a As Long, i As Long
Sheets("Sayfa1").Select
Set sh = Sheets("Sayfa2")
Set z = CreateObject("Scripting.dictionary")
sonsat = Cells(Rows.Count, "A").End(xlUp).Row
sh.Range("A2:D" & Rows.Count).ClearContents
ReDim myarr(1 To 4, 1 To sonsat)
liste = Range("A2:D" & sonsat).Value
For i = 1 To UBound(liste)
    deg = liste(i, 1) & liste(i, 2)
    If Not z.exists(deg) Then
        a = a + 1
        z.Add deg, a
        myarr(1, a) = liste(i, 1)
        myarr(2, a) = liste(i, 2)
    End If
    myarr(3, z.Item(deg)) = myarr(3, z.Item(deg)) + liste(i, 3)
    myarr(4, z.Item(deg)) = myarr(4, z.Item(deg)) + liste(i, 4)
Next i
Erase liste
Set z = Nothing
ReDim Preserve myarr(1 To 4, 1 To a)
sh.Select
Range("A2").Resize(a, 4) = Application.Transpose(myarr)
Erase myarr
MsgBox "İşlem Tamamlandı."
End Sub

Çok teşekkür ederim yardımınız için

 

[Orion1]

Çok teşekkür ederim yardımınız için

Rica ederim.
İyi çalışmalar.