Formül ile (Ödeme Sayısına Göre Bir Başka Sayfaya) Aktarma

[sirkülasyon]

Ekli dosyada Bordro sayfasında G5 sütununda yazan Ödeme Sayısına Göre bilgileri AKTAR sayfasına aktarmak istiyorum.
Bordro sayfasında aktarılacak sütunların renkleri farklı.

İkinci olarak ta İCMAL sayfasında
AKTAR sayfasında işin adına göre kaç kere aktarılmış ise İCMAL sayfasında ilgili yerlere aktarılsın.

İCMAL sayfasında G20 hücresine
Son Aktarılan Tahakkuk Tutarı
İCMAL sayfasında G22 hücresine
Aktarılan kesinti tutarlarının Toplamı
İCMAL sayfasında G23 hücresine
Aktarılan son kesinti tutarının Toplamı

Bir kaç kere talepte bulundum ama cevap verilmedi. Gerçekten ihtiyacım var.
Yardımcı olabilirseniz sevinirim.

Teşekkür ederim.


Not :
Örnek olsun diye 6 ay ve 6 kişilik yaptım.
Normalde 154 kişilik bir bordrodur. Ve bordroda tek ay vardır.

 

[Ziynettin]

Kodu deneyiniz.

Option Explicit
Sub aktar()
Dim s1 As Worksheet, s2 As Worksheet
Dim a(), b(), c(), k(), v(), d As Object, Krt As Variant
Dim i As Long, j As Integer, Say As Long, x As Integer
Set s1 = Sheets("Bordro")
Set s2 = Sheets("AKTAR")
Set d = CreateObject("scripting.dictionary")
a = s1.Range("E5:Y" & s1.Range("E" & Rows.Count).End(3).Row).Value
ReDim k(1 To UBound(a), 1 To 5)
    For i = 1 To UBound(a)
        Krt = a(i, 1) & CStr(a(i, 3))
        If Not d.exists(Krt) Then
            Say = Say + 1
            d(Krt) = Say
            For j = 1 To 4
                k(Say, j) = a(i, 10 + j)
            Next j
            k(Say, 5) = a(i, 21)
        End If
    Next i
On Error Resume Next
b = s2.Range("B5:B" & s2.Range("B" & Rows.Count).End(3).Row)
c = s2.Range("C2:BA2")
Say = 0
ReDim v(1 To UBound(b), 1 To UBound(c, 2))
    For i = 1 To UBound(b)
        Say = Say + 1
        For j = 1 To UBound(c, 2)
            Krt = b(i, 1) & CStr(c(1, j))
            For x = 0 To 4
                v(Say, j + x) = k(d(Krt), x + 1)
            Next x
        Next j
    Next i
Application.ScreenUpdating = False
If Say > 0 Then
    s2.Range("C5:BA" & Rows.Count).ClearContents
    s2.[C5].Resize(Say, UBound(c, 2)).NumberFormat = "#,##0.00"
    s2.[C5].Resize(Say, UBound(c, 2)) = v
End If
Application.ScreenUpdating = True
MsgBox "İşlem tamam.", vbInformation
End Sub

 

[sirkülasyon]

Sayın Ziynettin
Allah ne muradın varsa versin. çok çok Teşekkür ederim.

Rica etsem İCMAL sayfasını da çözer beni bu sıkıntıdan kurtarabilir misiniz?
Tekrar teşekkür ederim. Hakkını Helal et

 

[Ziynettin]

Dosyanız ekte,

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address(0, 0) = "D3" Then
Dim s1 As Worksheet, s2 As Worksheet, is_ad, tbl
Dim a(), b(), c(), v(), d As Object, Krt As Variant
Dim i As Long, Say As Long, x As Integer
Dim t1 As Double, t2 As Double, snc_t As Double
Set s1 = Sheets("Bordro")
Set s2 = Sheets("İCMAL")
Set d = CreateObject("scripting.dictionary")
is_ad = s2.[D3]
a = s1.Range("E5:Y" & s1.Range("E" & Rows.Count).End(3).Row).Value
ReDim c(1 To UBound(a), 1 To 5)
    For i = 1 To UBound(a)
        Krt = CStr(a(i, 3))
        If a(i, 1) = is_ad Then
            If Not d.exists(Krt) Then
                Say = Say + 1
                d(Krt) = Say
                c(Say, 1) = a(i, 11)
                c(Say, 2) = a(i, 12)
                c(Say, 3) = a(i, 13)
                c(Say, 4) = a(i, 14)
                c(Say, 5) = CDbl(a(i, 21))
            End If
        End If
    Next i
tbl = Array(c)
s2.[G20] = tbl(0)(Say, 4)
t1 = Application.Sum(Application.Index(c, , 5))
t2 = tbl(0)(Say, 5)
s2.[G22] = t1 - t2
s2.[G23] = t2
Say = 0
b = s2.Range("B9:B18").Value
On Error Resume Next
ReDim v(1 To UBound(b), 1 To 4)
    For i = 1 To UBound(b)
        Say = Say + 1
        Krt = CStr(b(i, 1))
        For x = 1 To 4
            v(Say, x) = c(d(Krt), x)
        Next x
    Next i
s2.[D9].Resize(Say, 4) = v
End If
End Sub

 

[sirkülasyon]

Sayın Ziynettin
Allah iki cihanda seni mesut eylesin
Teşekkür ederim. Sağ olasın

 

[sirkülasyon]

Sayın Ziynettin
İnceleyince fark ettim ki;
AKTAR sayfasında Ödeme sayısı 1 diyerek aktardığım zaman aktarıyor. Ödeme sayısı 2 dediğim zaman aktarılan 1' i siliyor. (SİLİNMEMESİ LAZIM)
İCMAL sayfasında da en son aktarılan kısmı getiriyor. Aktarılan tüm kısımları getirmesi lazım.