Aynı Fatura Numaralı Girişleri Kendi İçinde Toplamak

[stier_22]

Merhaba Arkadaşlar,

Elimde uzun bir liste var, örnek listem ekte olup burada yapmak istediğim şey aynı fatura numarası ile başlayan verileri Tek satıra indirgesin istiyorum. Bunu yaparkende Fatura Tarihi, Numarası ve KDV'si sabit kalacak sadece yanında bünyeye giren KDV'yi toplasın istiyorum. Fakat listede aynı numara ile başlayan ve aynı TC numarasına sahip matrahları farklı fişlerde var bunlarıda matrahına göre komut vererek toplamak mümkün müdür?

Örnek listede detaylı olarak gösterdim. Yardımcı olacak üstatlara şimdiden çok teşekkür ederim.

 

[muygun]

Merhaba;
Eki deneyin.
İyi çalışmalar.

 

[stier_22]

Merhaba;
Eki deneyin.
İyi çalışmalar.

Merhaba üstad öncelikle teşekkür ederim.
Fakat sizin yaptığınız çalışmada bünyeye girende ilk gördüğü KDV'yi getiriyor benim istediğim her faturayı fatura numarasına göre kendi içinde toplasın o şekilde Bünyeye giren L sütunundaki kdvsini getirsin.

Yani örnek olarak 111822 no.lu fatura 9 defa kullanılmış ve bunun bünyeye giren L sütununda toplamda 19.560,68 Lirası kullanılmış Dolayısı ile o 9 fatura yerine tek fatura olarak gelsin ve bünyeye giren kısmında da 9 faturanın KDV'sinin toplamı gelsin istiyorum. Örnek excelde yaptığımda buydu.

 

[tahsinanarat]

Aşağıdaki kodu denermisiniz.
Not: kodlar evvelce bu siteden temin ettiğim kodlardır. Hangi hocamın ise hakkını helal etsin.

Sub Faturalari_duzenleme()
Dim sat As Long, z As Object, myarr(), list(), a As Long
Dim i As Long, deg As String, baslangic As Date, n As Long
sat = Sheets("VAR OLAN LİSTE").Cells(65536, "C").End(xlUp).Row
Application.ScreenUpdating = False

Sheets("OLMASINI İSTEDİĞİM LİSTE").Range("C5:S65536").ClearContents
If sat < 5 Then Exit Sub
baslangic = Now
list = Sheets("VAR OLAN LİSTE").Range("C5:Q" & sat).Value
Set z = CreateObject("Scripting.Dictionary")
ReDim myarr(1 To 22, 1 To sat)
For i = 1 To UBound(list, 1)
    deg = list(i, 1) & "-" & list(i, 3) & "-" & list(i, 4)
    If Not z.Exists(deg) Then
        n = n + 1
        z.Add deg, n
        myarr(3, n) = list(i, 1)
        myarr(4, n) = list(i, 2)
        myarr(5, n) = list(i, 3)
        myarr(6, n) = list(i, 4)
        myarr(7, n) = list(i, 5)
        myarr(8, n) = list(i, 6)
        myarr(9, n) = list(i, 7)
        myarr(10, n) = list(i, 8)
        myarr(11, n) = list(i, 9)
        myarr(13, n) = list(i, 11)
        myarr(14, n) = list(i, 12)
        myarr(15, n) = list(i, 13)
        myarr(16, n) = list(i, 14)
        myarr(17, n) = list(i, 15)
   End If
    myarr(12, z.Item(deg)) = myarr(12, z.Item(deg)) + list(i, 10)
Next i
Set z = Nothing
Sheets("OLMASINI İSTEDİĞİM LİSTE").Select
sat = Sheets("OLMASINI İSTEDİĞİM LİSTE").Range("C" & Rows.Count).End(3).Row + 1
ReDim Preserve myarr(1 To 22, 1 To n)
Cells(sat, 1).Resize(n, 22) = Application.Transpose(myarr)
Erase myarr
Sırala
Application.ScreenUpdating = True
MsgBox "Süre : " & Format(Now - baslangic, "hh:mm:ss") & vbLf & _
"Aktarıldı", vbOKOnly + vbInformation
End Sub


Sub Sırala()
Range("B5").Select
satir = 5
Do While Range("C" & satir) <> ""
DoEvents
Range("B" & satir) = satir - 4
satir = satir + 1
Loop
End Sub

 

[stier_22]

Aşağıdaki kodu denermisiniz.
Not: kodlar evvelce bu siteden temin ettiğim kodlardır. Hangi hocamın ise hakkını helal etsin.

Sub Faturalari_duzenleme()
Dim sat As Long, z As Object, myarr(), list(), a As Long
Dim i As Long, deg As String, baslangic As Date, n As Long
sat = Sheets("VAR OLAN LİSTE").Cells(65536, "C").End(xlUp).Row
Application.ScreenUpdating = False

Sheets("OLMASINI İSTEDİĞİM LİSTE").Range("C5:S65536").ClearContents
If sat < 5 Then Exit Sub
baslangic = Now
list = Sheets("VAR OLAN LİSTE").Range("C5:Q" & sat).Value
Set z = CreateObject("Scripting.Dictionary")
ReDim myarr(1 To 22, 1 To sat)
For i = 1 To UBound(list, 1)
    deg = list(i, 1) & "-" & list(i, 3) & "-" & list(i, 4)
    If Not z.Exists(deg) Then
        n = n + 1
        z.Add deg, n
        myarr(3, n) = list(i, 1)
        myarr(4, n) = list(i, 2)
        myarr(5, n) = list(i, 3)
        myarr(6, n) = list(i, 4)
        myarr(7, n) = list(i, 5)
        myarr(8, n) = list(i, 6)
        myarr(9, n) = list(i, 7)
        myarr(10, n) = list(i, 8)
        myarr(11, n) = list(i, 9)
        myarr(13, n) = list(i, 11)
        myarr(14, n) = list(i, 12)
        myarr(15, n) = list(i, 13)
        myarr(16, n) = list(i, 14)
        myarr(17, n) = list(i, 15)
   End If
    myarr(12, z.Item(deg)) = myarr(12, z.Item(deg)) + list(i, 10)
Next i
Set z = Nothing
Sheets("OLMASINI İSTEDİĞİM LİSTE").Select
sat = Sheets("OLMASINI İSTEDİĞİM LİSTE").Range("C" & Rows.Count).End(3).Row + 1
ReDim Preserve myarr(1 To 22, 1 To n)
Cells(sat, 1).Resize(n, 22) = Application.Transpose(myarr)
Erase myarr
Sırala
Application.ScreenUpdating = True
MsgBox "Süre : " & Format(Now - baslangic, "hh:mm:ss") & vbLf & _
"Aktarıldı", vbOKOnly + vbInformation
End Sub


Sub Sırala()
Range("B5").Select
satir = 5
Do While Range("C" & satir) <> ""
DoEvents
Range("B" & satir) = satir - 4
satir = satir + 1
Loop
End Sub

Üstat çok teşekkür ederim tam istediğim gibi oldu. Birde buna nasıl düğme ekleyebilirim kısa yoldan acaba butona basıp çalıştırmak için.
Birde konu ile alakasız ama siz çocuk şubeden emekli polis memuru olabilir misiniz? Yoksa isim soy isim benzerliği mi acaba