• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

P

Protector24

Katılım
15 Mayıs 2018
Mesajlar
7
Excel Vers. ve Dili
Microsoft Excel 2016(English)
Microsoft Excel 2010(English)
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.
 
Kontrol olarak sadece Numara mı esas alınacak, yoksa firma ve numara ikisi de göz önüne alınacak
 
Dosyanız ektedir.:cool:
Protector24' Alıntı:
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.
Genişletmek için tıkla ...
Dosyanız linktedir.:cool:

DOSYAYI INDIR

Kod: 
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
 
Kod: 
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
 
Son düzenleme:
veyselemre' Alıntı:
Kod: 
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
Genişletmek için tıkla ...
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.
 
Orion1' Alıntı:
Dosyanız ektedir.:cool:

Dosyanız linktedir.:cool:

DOSYAYI INDIR

Kod: 
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
Genişletmek için tıkla ...

Çok teşekkür ederim yardımınız için :)
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst