Aynı verileri toplamak

[tk123]

Açıklama : Düzenle tuşuna basıldığında bilgigirişi yapılan kısımdaki bilgileri tablo kısmına aktaracak ve firma ise bilgi girişi kısmamında o firmaya ait vergi numarasına ait kaç belge varsa belge sayısı kısmına toplam olarak yazacak ve belgelerin toplamını toplacak aynı işlem T.C Kimlik No içinde uygulanacak.
Tablonun içinde örnek mevcut.

İlginiz için şimdiden teşekkürler.

 

[asi_kral]

Açıklama : Düzenle tuşuna basıldığında bilgigirişi yapılan kısımdaki bilgileri tablo kısmına aktaracak ve firma ise bilgi girişi kısmamında o firmaya ait vergi numarasına ait kaç belge varsa belge sayısı kısmına toplam olarak yazacak ve belgelerin toplamını toplacak aynı işlem T.C Kimlik No içinde uygulanacak.
Tablonun içinde örnek mevcut.

İlginiz için şimdiden teşekkürler.

Merhaba
Boş bir module kopyalayın ve deneyin.

Option Explicit
Sub bilgieri_aktar_topla_1967()
'Konu       :   Mükerrerleri Tekle Aynı Zamanda Topla
'Mail       :   m.batu.1967@gmail.com
'Coder By   :   asi_kral_1967
Dim asi, kral
Dim a, b, c, d As New Collection
Set asi = Sheets("Bilgigirişi")
Set kral = Sheets("Tablo")
Application.ScreenUpdating = False
kral.Range("A2:G" & Rows.Count).ClearContents
For a = 2 To asi.Cells(Rows.Count, "B").End(xlUp).Row
If WorksheetFunction.CountIf(asi.Range("B2:B" & a), _
asi.Cells(a, "B")) = 1 Then
d.Add asi.Cells(a, "B"), CStr(asi.Cells(a, "B"))
End If
Next
b = 2
For Each c In d
kral.Cells(b, "B") = c
If WorksheetFunction.VLookup(c, asi.Range("B:E"), 2, 0) _
<> Empty Then
kral.Cells(b, "C") = WorksheetFunction.VLookup(c, asi. _
Range("B:E"), 2, 0)
End If
If WorksheetFunction.VLookup(c, asi.Range("B:E"), 3, 0) _
<> Empty Then
kral.Cells(b, "D") = WorksheetFunction.VLookup(c, asi. _
Range("B:E"), 3, 0)
End If
If WorksheetFunction.VLookup(c, asi.Range("B:E"), 4, 0) _
<> Empty Then
kral.Cells(b, "E") = WorksheetFunction.VLookup(c, asi. _
Range("B:E"), 4, 0)
End If
kral.Cells(b, "F") = WorksheetFunction.SumIf(asi.Range("B:B"), _
c, asi.Range("F:F"))
kral.Cells(b, "G") = WorksheetFunction.SumIf(asi.Range("B:B"), _
c, asi.Range("G:G"))
kral.Cells(b, "A") = b - 1
b = b + 1
Next
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation, "asi_kral_1967"
End Sub

Eki inceleyiniz.

 

[tk123]

Teşekkür

ilginiz ve yardımınız için çok teşekkür ederim çok makule geçti.

 

[asi_kral]

ilginiz ve yardımınız için çok teşekkür ederim çok makule geçti.

Kolay Gelsin.