anilman
Altın Üye
- Katılım
- 12 Ağustos 2020
- Mesajlar
- 65
- Excel Vers. ve Dili
- Microsoft 365 TR 64 Bit
- Altın Üyelik Bitiş Tarihi
- 25-09-2027
Merhaba, linkteki dosyada yapmak istediğim makro kod ile İND Sayfasındaki listede şart olarak (O) Karşıt İnceleme sütunu dolu olup ve aynı vergi numaraya sahip firmaları, TUTANAK TABLOSU sayfası örnekteki gibi firma adını, vergi numarasını ve dönemini yerleştirip İND. Sayfasındaki (J) sütunundaki MATRAH ile (O) sütunundaki KARŞIT İNCELEME KDV'leri de dönemsel olarak toplamasını istiyorum, daha önce bu konu hakkında yardım almıştım ama sadece TUTANAK sayfasına KDV'yi alıyordu şimdi ise Matrahında dahil olmasını istiyorum Konu hakkında yardımınız için şimdiden teşekkürler.
www.dosya.tc
Kodlar:
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
TUTANAK.xlsm dosyasını indir - download
TUTANAK.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle
www.dosya.tc
Kodlar:
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