Aynı Vergi Numaralı Firmaları ve Değerlerini Başka Sayfada Birleştirme

[anilman]

Merhaba, ekteki dosyada yapmak istediğim Makro Kod yardımıyla İND Sayfasındaki listede (O) Karşıt İnceleme sütunu dolu olup ve aynı vergi numaraya sahip firmaları, TUTANAK TABLOSU sayfasındaki örnek gibi firma adını, vergi numarasını ve dönemini yerleştirip yine Tutanak sütunundaki KDV'leri de dönemsel olarak toplamasını istiyorum. Şimdiden Teşekkürler.

 

[Korhan Ayhan]

Merhaba,

Linkteki konuları inceleyiniz.

KDV Listesi

 

[anilman]

Merhaba, linkleri inceledim fakat isteğim ile ilgili sonuç alamadım. Bu çalışma ile ilgili daha önce linkteki https://paply.org/5eh konuyu açmıştım ama sayfadaki kodla oynayarak yukarıdaki isteğimi yerine getiremedim. Konuyla ilgili tekrar destek olursanız sevinirim, teşekkürler

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Tutanak_Tablosu_Olustur()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object
    Dim Son As Long, Veri As Variant, Aranan As String
    Dim Say As Long, X As Long, Zaman As Double
    
    Zaman = Timer
    
    Set S1 = Sheets("İND")
    Set S2 = Sheets("TUTANAK TABLOSU")
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
    
    S2.Range("B3:E22").ClearContents
    
    Son = WorksheetFunction.Max(6, S1.Cells(S1.Rows.Count, 3).End(3).Row)
    
    Veri = S1.Range("A5:T" & Son).Value
    
    ReDim Liste(1 To UBound(Veri, 1), 1 To 4)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 15) Then
            Aranan = Format(Veri(X, 3), "yyyy") & "/" & Format(Veri(X, 3), "mm") & "|" & Veri(X, 7)
            If Not Dizi.Exists(Aranan) Then
                Say = Say + 1
                Dizi.Add Aranan, Say
                Liste(Say, 1) = Veri(X, 6)
                Liste(Say, 2) = Veri(X, 7)
                Liste(Say, 3) = Split(Aranan, "|")(0)
                Liste(Say, 4) = Veri(X, 15)
            Else
                Liste(Dizi.Item(Aranan), 4) = Liste(Dizi.Item(Aranan), 4) + Veri(X, 15)
            End If
        End If
    Next
    
    If Say > 0 Then
        S2.Range("B3").Resize(Say, 4) = Liste
        MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    End If

    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing
End Sub

 

[anilman]

Elinize sağlık, çok teşekkürler