Topla ve 2.Sayfaya Aktar

[aligunes]

Teşekkür ederim ilginiz için ben sayfa 1 deki aktar tuşuna basıyorum senin yaptığı 2.sayfadaki raporla tuşunu yeni fark ettim yaptığı aynen istedigim gibi sadece ufak bi eksikligi var raporla sonucundaki kişi sayısı ve para miktarını raporlama sonunda uyarı butonu olarak verse sorun kalmayacak

 

[Recep İpek]

Kodları aşağıdaki ilaveleri yapabilirsiniz.

Sub AktarTopla()
Dim a, b, i, n, sat, veri()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
'*******************************************
a = s1.Range("a1:h" & s1.[a65536].End(3).Row).Value
ReDim veri(1 To UBound(a, 1), 1 To 8)
'*******************************************
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 1 To UBound(a, 1)
z = a(i, 6)
If Not IsEmpty(z) Then
If Not .exists(z) Then
n = n + 1
veri(n, 1) = a(i, 1)
veri(n, 2) = a(i, 2)
veri(n, 3) = a(i, 3)
veri(n, 4) = a(i, 4)
veri(n, 5) = a(i, 5)
veri(n, 6) = a(i, 6)
veri(n, 8) = a(i, 8)
.Add z, n
End If
veri(.Item(z), 7) = veri(.Item(z), 7) + a(i, 7)
End If
toplam = toplam + a(i, 7)
Next i
End With
'*******************************************
sat = s2.[a65536].End(3).Row + 1
s2.Range(s2.Cells(1, "a"), s2.Cells(sat, "h")).ClearContents
s2.[a1].Resize(n, 8).Value = veri
''*******************************************
s2.Select
MsgBox "Raporlama Bitti" & Chr(13) & "Aktarılan kişi sayısı : " & n & " Tutar :" & toplam, vbInformation, "Bilgi"
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[aligunes]

Sub AktarTopla()
Dim a, b, i, n, sat, veri()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
'*******************************************
a = s1.Range("a1:h" & s1.[a65536].End(3).Row).Value
ReDim veri(1 To UBound(a, 1), 1 To 8)
'*******************************************
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 1 To UBound(a, 1)
z = a(i, 6)
If Not IsEmpty(z) Then
If Not .exists(z) Then
n = n + 1
veri(n, 1) = a(i, 1)
veri(n, 2) = a(i, 2)
veri(n, 3) = a(i, 3)
veri(n, 4) = a(i, 4)
veri(n, 5) = a(i, 5)
veri(n, 6) = a(i, 6)
veri(n, 8) = a(i, 8)
.Add z, n
End If
veri(.Item(z), 7) = veri(.Item(z), 7) + a(i, 7)
End If
toplam = toplam + a(i, 7)
Next i
End With
'*******************************************
sat = s2.[a65536].End(3).Row + 1
s2.Range(s2.Cells(1, "a"), s2.Cells(sat, "h")).ClearContents
s2.[a1].Resize(n, 8).Value = veri
''*******************************************
s2.Select
MsgBox "Raporlama Bitti" & Chr(13) & "Aktarılan kişi sayısı : " & n & " Tutar :" & toplam, vbInformation, "Bilgi"
Set s1 = Nothing
Set s2 = Nothing
End Sub


Arkadaşlar Birleştir Topla 2.Sayfaya Aktar makrosunda "h" sutununa t.c.kimlik no ekleyecegim isimsoyisim bir sutun ileri kayması gerekiyor isim soyisim "i" sutununa kayması gerekiyor yardımcı olursanız sevinirim.teşekkür ederim...

 

[Recep İpek]

Kodları aşağıdaki şekilde değiştiriniz.

Sub AktarTopla()
Dim a, b, i, n, sat, veri()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
'*******************************************
a = s1.Range("a1:I" & s1.[a65536].End(3).Row).Value
ReDim veri(1 To UBound(a, 1), 1 To 9)
'*******************************************
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To UBound(a, 1)
        z = a(i, 6)
           If Not IsEmpty(z) Then
                 If Not .exists(z) Then
                    n = n + 1
                    veri(n, 1) = a(i, 1)
                    veri(n, 2) = a(i, 2)
                    veri(n, 3) = a(i, 3)
                    veri(n, 4) = a(i, 4)
                    veri(n, 5) = a(i, 5)
                    veri(n, 6) = a(i, 6)
                    veri(n, 8) = a(i, 8)
                    veri(n, 9) = a(i, 9)
                    .Add z, n
                  End If
                    veri(.Item(z), 7) = veri(.Item(z), 7) + a(i, 7)
                End If
                toplam = toplam + a(i, 7)
    Next i
End With
'*******************************************
sat = s2.[a65536].End(3).Row + 1
s2.Range(s2.Cells(1, "a"), s2.Cells(sat, "I")).ClearContents
s2.[a1].Resize(n, 9).Value = veri
''*******************************************
s2.Select
MsgBox "Raporlama Bitti" & Chr(13) & "Aktarılan kişi sayısı : " & n & " Tutar :" & toplam, vbInformation, "Bilgi"
Set s1 = Nothing
Set s2 = Nothing
End Sub