Çek Takip...

[Bujrak]

Merhaba

çek takip sayfama çek bilgilerini girdiğimde(Firma ismi,vadesi,tutarı v.s.) istediğim,girilen bilgilerin rapor sayfasında tablo halinde firma firma ayrılmasını....

x firmasındaki çekler toplanacak
y firmasında çekler toplanacak
Örnek uygulama aşağıdadır sadece isteğim rapor sayfasının oluşturulması...


Teşekkürler...

 

[Orion1]

Dosyanız ektedir.

Option Base 1
Sub cek_59()
Dim sh As Worksheet, z As Object, sat1 As Long, sat2 As Long
Dim i As Long, liste(), deg As String, vkey, s, toplam As Double
Set sh = Sheets("VERİ")
Sheets("RAPOR").Select
If Range("B1").Value = "" Then
    MsgBox "B1 hücresine Bir firma ismi girmelisiniz!" & vbLf & _
    "İşlem İptal edildi.", vbCritical, "UYARI"
    Range("B1").Select
    Exit Sub
End If
Application.ScreenUpdating = False
Range("A5:I65536").Clear
sh.Range("A1").AutoFilter
sat1 = sh.Cells(65536, "E").End(xlUp).Row
If sat1 < 2 Then sh.Range("A1").AutoFilter: Application.ScreenUpdating = True: Exit Sub
Set z = CreateObject("Scripting.Dictionary")
liste = sh.Range("E2:F" & sat1)
For i = 1 To UBound(liste)
    If liste(i, 1) <> "" And liste(i, 2) <> "" Then
        deg = liste(i, 1) & "-" & liste(i, 2)
        If Not z.exists(deg) Then
            z.Add deg, Nothing
        End If
    End If
Next i
Erase liste
If z.Count < 1 Then sh.Range("A1").AutoFilter: Application.ScreenUpdating = True: Exit Sub
sat2 = 5
For Each vkey In z
    s = Split(vkey, "-")
    sh.Range("A1").AutoFilter field:=1, Criteria1:=Range("B1").Value
    sh.Range("A1").AutoFilter field:=5, Criteria1:=s(0)
    sh.Range("A1").AutoFilter field:=6, Criteria1:=s(1)
    If WorksheetFunction.Subtotal(103, sh.Range("E2:E" & sat1)) > 0 Then
        toplam = WorksheetFunction.Subtotal(9, sh.Range("D2:D" & sat1))
        Cells(sat2, "A").Value = vkey
        sh.Range("A1").CurrentRegion.Copy Range("A" & sat2 + 1)
        sat2 = Cells(65536, "E").End(xlUp).Row + 1
        Cells(sat2, "A").Value = "TOPLAM"
        Cells(sat2, "D").Value = toplam
        Cells(sat2, "D").NumberFormat = "#,##0.00"
        toplam = 0
        sat2 = sat2 + 2
    End If
Next
sh.Range("A1").AutoFilter
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[msbilir]

Dosyanız ektedir.

Option Base 1
Sub cek_59()
Dim sh As Worksheet, z As Object, sat1 As Long, sat2 As Long
Dim i As Long, liste(), deg As String, vkey, s, toplam As Double
Set sh = Sheets("VERİ")
Sheets("RAPOR").Select
If Range("B1").Value = "" Then
    MsgBox "B1 hücresine Bir firma ismi girmelisiniz!" & vbLf & _
    "İşlem İptal edildi.", vbCritical, "UYARI"
    Range("B1").Select
    Exit Sub
End If
Application.ScreenUpdating = False
Range("A5:I65536").Clear
sh.Range("A1").AutoFilter
sat1 = sh.Cells(65536, "E").End(xlUp).Row
If sat1 < 2 Then sh.Range("A1").AutoFilter: Application.ScreenUpdating = True: Exit Sub
Set z = CreateObject("Scripting.Dictionary")
liste = sh.Range("E2:F" & sat1)
For i = 1 To UBound(liste)
    If liste(i, 1) <> "" And liste(i, 2) <> "" Then
        deg = liste(i, 1) & "-" & liste(i, 2)
        If Not z.exists(deg) Then
            z.Add deg, Nothing
        End If
    End If
Next i
Erase liste
If z.Count < 1 Then sh.Range("A1").AutoFilter: Application.ScreenUpdating = True: Exit Sub
sat2 = 5
For Each vkey In z
    s = Split(vkey, "-")
    sh.Range("A1").AutoFilter field:=1, Criteria1:=Range("B1").Value
    sh.Range("A1").AutoFilter field:=5, Criteria1:=s(0)
    sh.Range("A1").AutoFilter field:=6, Criteria1:=s(1)
    If WorksheetFunction.Subtotal(103, sh.Range("E2:E" & sat1)) > 0 Then
        toplam = WorksheetFunction.Subtotal(9, sh.Range("D2:D" & sat1))
        Cells(sat2, "A").Value = vkey
        sh.Range("A1").CurrentRegion.Copy Range("A" & sat2 + 1)
        sat2 = Cells(65536, "E").End(xlUp).Row + 1
        Cells(sat2, "A").Value = "TOPLAM"
        Cells(sat2, "D").Value = toplam
        Cells(sat2, "D").NumberFormat = "#,##0.00"
        toplam = 0
        sat2 = sat2 + 2
    End If
Next
sh.Range("A1").AutoFilter
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

hocam merhabalar,
yapmış olduğunuz programı kullanıyorum. ellerinize sağlık ancak benim bilgisayarda çalışan program başka bilgisayarda hata veriyor. verdiği hatayla ilgili olarak resimler şu şekilde. bi bakarmısınız.

http://i1008.hizliresim.com/2010/8/2/1619.bmp
http://i1008.hizliresim.com/2010/8/2/1627.bmp