Birden Fazla fatura Kaydını teke düşürme

[KARTAL133]

Merhaba Arkadaşlar

Ekte pivotyable ile bir çalışma yaptım. Ancak Pivotyable olarak excel çok kastığından dolayı makro olarak yapmak istiyorum.
konu ile yardımlarınızı rica ederim.

Yardımlarınızı riçin şimdiden çok teşekkürler

 

[KARTAL133]

Merhaba

Yardımcı olacak kimse yok mu

 

[çıtır]

Deneyiniz.

Sub Benzersiz()
Dim s1 As Worksheet: Dim s2 As Worksheet
Set s1 = Sheets("Data"): Set s2 = Sheets("Liste")
Application.ScreenUpdating = False
son = s1.Cells(65355, "A").End(3).Row
s1.Select
s1.Range("A1:BX" & son).Select
Selection.Copy
s2.Select
s2.Range("A1").Select
 ActiveSheet.Paste
    Application.CutCopyMode = False
ActiveSheet.Range("A1:BX" & son).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8), Header:=xlYes
s2.Range("A1").Select
Application.ScreenUpdating = True
MsgBox "İŞLEM TAMAM."
End Sub

 

[KARTAL133]

Merhaba

Yardımlarınız için teşekkürler anacak istediğim gibi olmamış
Tutar olarak sadece içlerinden sadece 1 satırdaki toplamı almış
Örnek olarak AAA2019000005491 nolu fat. Toplamı 1760,00 TL
KDV 316,80 TL yapıyor bunları ayrı ayır toplanıp ayrı ayrı satırlara yazması gerekiyor

 

[çıtır]

Fiyatlar ve KDV hangi sütunda olduğunu bulumadım.Siz çoketopla ile ilave ediniz.

 

[Korhan Ayhan]

Normalde pivot table (özet tablo) exceli kasmaması gerekir.

 

[KARTAL133]

Veri çok olduğundan kasıyor daha öncede karşılaştım

 

[KARTAL133]

Fiyatlar ve KDV hangi sütunda olduğunu bulumadım.Siz çoketopla ile ilave ediniz.

Tutar ve kdv aynı sutunda yer Tutarları yer alıyor
Ayrım için AH ayrım yapabiliriz

Recoverable Tax

Nonrecoverable Tax

Recoverable Tax

Nonrecoverable Tax

Bunlar kdv isimler.

 

[çıtır]

Gerekli ayrımları yapınız.Ondan sonra kodlar oluşturulsun.KDV % kaç tır vs.Benim için konu kapanmıştır.İlgilenen arkadaşlar gerekli yardımda bulunur umarım.Kolay gelsin.

 

[Korhan Ayhan]

Ekteki dosyayı inceleyiniz.

Yoğun veride deneyip sonucu da bildirirseniz sevinirim.

Kullanılan kod;

Option Explicit

Sub Rapor()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object, Veri As Variant
    Dim Son As Long, X As Long, Aranan As String, Say As Long, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Data")
    Set S2 = Sheets("Liste")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    
    Veri = S1.Range("A2:BX" & Son).Value
    
    S2.Range("A2:H" & S2.Rows.Count).Clear
    
    ReDim Liste(1 To UBound(Veri), 1 To 8)
    
    For X = 1 To UBound(Veri)
        Aranan = Veri(X, 3) & Veri(X, 5) & Veri(X, 6) & Veri(X, 9)
        If Not Dizi.Exists(Aranan) Then
            Say = Say + 1
            Dizi.Add Aranan, Say
            Liste(Say, 1) = Veri(X, 3)
            Liste(Say, 2) = Veri(X, 5)
            Liste(Say, 3) = Veri(X, 6)
            Liste(Say, 4) = Veri(X, 9)
            Liste(Say, 5) = Veri(X, 8)
            If Veri(X, 21) = "Item" Then Liste(Say, 6) = Liste(Say, 6) + Veri(X, 38)
            If Veri(X, 21) = "Tax" Then Liste(Say, 7) = Liste(Say, 7) + Veri(X, 38)
            Liste(Say, 8) = Liste(Say, 6) + Liste(Say, 7)
        Else
            Liste(Say, 1) = Veri(X, 3)
            Liste(Say, 2) = Veri(X, 5)
            Liste(Say, 3) = Veri(X, 6)
            Liste(Say, 4) = Veri(X, 9)
            Liste(Say, 5) = Veri(X, 8)
            If Veri(X, 21) = "Item" Then Liste(Dizi.Item(Aranan), 6) = Liste(Dizi.Item(Aranan), 6) + Veri(X, 38)
            If Veri(X, 21) = "Tax" Then Liste(Dizi.Item(Aranan), 7) = Liste(Dizi.Item(Aranan), 7) + Veri(X, 38)
            Liste(Dizi.Item(Aranan), 8) = Liste(Dizi.Item(Aranan), 6) + Liste(Dizi.Item(Aranan), 7)
        End If
    Next
    
    S2.Range("A2").Resize(Say, 8) = Liste
    S2.Range("A" & Say + 2).Resize(1, 8).Font.Bold = True
    S2.Cells(Say + 2, 1) = "Genel Toplam"
    S2.Cells(Say + 2, 6) = "=SUM(F2:F" & Say + 1 & ")"
    S2.Cells(Say + 2, 7) = "=SUM(G2:G" & Say + 1 & ")"
    S2.Cells(Say + 2, 8) = "=SUM(H2:H" & Say + 1 & ")"
    S2.Range("F2:H" & Say + 2).Style = "Comma"
    S2.Range("A:H").EntireColumn.AutoFit
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[KARTAL133]

Elinize yüreğinize sağlık istediğim gibi olmuş çok teşekkürler

 

[Korhan Ayhan]

Yoğun veride süre olarak nasıl bir sonuç aldınız?

 

[KARTAL133]

Evet aldım kontrol ettim sorun yok teşekkürler

 

[Korhan Ayhan]

İşlem süresini sormuştum?

 

[KARTAL133]

Merhaba

25 Sn Kadar Sürüyor
çok teşekkürler