Giriş Çıkış Tablosu - Raporlama yapma

[qhacks]

Giriş ve çıkış listesi adlı iki adet tablo var. Bu tabloları ekte gönderdiğim dosyadaki gibi otomatik olarak raporlamak istiyorum.Nasıl Yapılabilir?

Teşekkürler

 

[Orion1]

Dosyanız ektedir.

Sub stok_59()
Dim sg As Worksheet, sc As Worksheet
Dim satg As Long, satc As Long, sat As Long
Dim k As Range, adr As String, giria As String, i As Long
Dim gkap As Double, gkg As Double, ckap As Double, ckg As Double
Sheets("giriscikislistesi").Select
Set sg = Sheets("giris")
Set sc = Sheets("cikis")
Application.ScreenUpdating = False
Range("A3:H65536").Clear
sat = 3
satg = sg.Cells(65536, "B").End(xlUp).Row
satc = sc.Cells(65536, "C").End(xlUp).Row
If satg < 3 Then GoTo son
For i = 3 To satg
    If WorksheetFunction.CountIf(sg.Range("B3:B" & i), sg.Cells(i, "B").Value) = 1 Then
        gkap = 0: gkg = 0
        giris = sg.Cells(i, "B").Value
        gkap = WorksheetFunction.SumIf(sg.Range("B" & i & ":B" & satg), sg.Range("B" & i).Value, sg.Range("D" & i & ":D" & satg))
        gkg = WorksheetFunction.SumIf(sg.Range("B" & i & ":B" & satg), sg.Range("B" & i).Value, sg.Range("E" & i & ":E" & satg))
        Cells(sat, "B").Value = giris
        Cells(sat, "D").Value = sg.Cells(i, "C").Value
        Cells(sat, "E").Value = gkap
        Cells(sat, "G").Value = gkg
        Range("A" & sat & ":H" & sat).Interior.ColorIndex = 15
        sat = sat + 1
        Set k = sc.Range("C3:C" & satc).Find(giris, , xlValues, xlWhole)
        If Not k Is Nothing Then
            adr = k.Address
            ckap = 0: ckg = 0
            Do
                ckap = ckap + k.Offset(0, 2).Value
                ckg = ckg + k.Offset(0, 3).Value
                Cells(sat, "C").Value = k.Offset(0, -1).Value
                Cells(sat, "F").Value = k.Offset(0, 2).Value
                Cells(sat, "H").Value = k.Offset(0, 3).Value
                Range("A" & sat & ":H" & sat).Interior.ColorIndex = 6
                Set k = sc.Range("C3:C" & satc).FindNext(k)
                sat = sat + 1
            Loop While Not k Is Nothing And k.Address <> adr
        End If
        sat = sat + 1
        Cells(sat, "D").Value = "BAKİYE"
        Cells(sat, "E").Value = gkap - ckap
        Cells(sat, "G").Value = gkg - ckg
        sat = sat + 2
    End If
Next
son:
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[muygun]

Merhaba;
Evren bey sorunu çözmüş ama işlevlerle bir çözümde benden.
İyi çalışmalar.