Kasa

[Barons]

merhaba

Database sayfasında J kolonunda "kasa" verisinin 2 tarih aralığında raporunu, kasarapor sayfasına almak istiyorum.Ancak almak istediğim tarih aralığının 1 gün öncesi kasa devri olarak hesaplatmam gerekiyor.Aslında Evren hocam sağolsun bu kasa raporunu halletti ancak devir konusuda sözkonusu.
örnek:
ilk tarih:12/01/2010 olsun.
son tarih: 16/01/2010 olsun.

bu iki tarih arası rapor almanın yanısıra,1 gün öncesine yani 11/01/2010 tarihine kadar olan kasa giriş ve çıkışlarının farkınıda devir olarak hesaplatmak mümkünmüdür?

teşekkürler

 

[meslan]

merhaba
Kendi isteğine göre uyarla
Satır başlıklarını ;Giriş_Tutar ,Çıkış_Tutar olarak düzelt. ya da boşluksuz yaz.

Private Sub CommandButton1_Click()
Set s1 = Sheets("Kasarapor")
s1.[a2:l65536].ClearContents
Dim Cn As Object, Rs As Object
Set Cn = CreateObject("ADODB.Connection")
Set Rs = CreateObject("ADODB.Recordset")
Cn.Open _
"DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & _
    ThisWorkbook.FullName
Rs.Open "select distinct sum ([COLOR="Red"]Giriş_Tutar[/COLOR])  From [database$] where (Cdate([COLOR="red"]Tarih[/COLOR])) <  '" & CDate(DTPicker1.Value) & "'", Cn, 1, 1
Giren = Rs(0)
Rs.Close
Rs.Open "select distinct sum ([COLOR="red"]Çıkış_Tutar[/COLOR])  From [[COLOR="red"]database[/COLOR]$] where (Cdate(T[COLOR="red"]arih[/COLOR])) < '" & CDate(DTPicker1.Value) & "'", Cn, 1, 1
Cikan = Rs(0)
Rs.Close
Cn.Close
If Cikan = Empty Then Cikan = 0
If Giren = Empty Then Giren = 0

Set s2 = Sheets("database")
s1.Cells(4, "r") = Format(CDbl(Giren - Cikan), "###,##0.00")
If Giren - Cikan > 0 Then s1.Cells(2, "K") = Format(CDbl(Giren - Cikan), "###,##0.00"): s1.Cells(2, 1) = 1
If Cikan - Giren > 0 Then s1.Cells(2, "L") = Format(CDbl(Cikan - Giren), "###,##0.00"): s1.Cells(2, 1) = 1

c = s2.Range("A2:L" & s2.[a65536].End(3).Row).Value
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
 For i = 1 To UBound(c, 1)
    If CDate(c(i, 2)) >= CDate(DTPicker1.Value) And CDate(c(i, 2)) < CDate(DTPicker2.Value) Then
        son = s1.[a65536].End(3).Row + 1
        For y = 1 To 12
            s1.Cells(son, y) = c(i, y)
        Next y
    End If
 Next i
End With
End Sub

 

[Barons]

teşekkürler,,,
uyarladım ama hatalı hesaplıyor.Dosya ektedir.

 

[meslan]

teşekkürler,,,
uyarladım ama hatalı hesaplıyor.Dosya ektedir.

2. mesaja dosyanızı ekledim.

 

[Barons]

Süper olmuş...elinize sağlık..teşekkürler

 

[Barons]

Sn.Meslan,

makro süper çalışıyor..sadece ufak bir sorun var.
database sayfasında banka sütununda veri olarak sadece "kasa" yok.diğer bir çok bankanın ismide var..dolayısı ile sadece kasa olanlarını seçip bu işlemi yapmam gerekiyor.
Bunuda hallolursa tam süper olacak.

 

[meslan]

Sn.Meslan,

makro süper çalışıyor..sadece ufak bir sorun var.
database sayfasında banka sütununda veri olarak sadece "kasa" yok.diğer bir çok bankanın ismide var..dolayısı ile sadece kasa olanlarını seçip bu işlemi yapmam gerekiyor.
Bunuda hallolursa tam süper olacak.

Herhalde şimdi tamamdır.

 

[Barons]

Çok teşekkürler...Allah razı olsun..kısmetiniz bol,sağlık ve sıhhatiniz her zaman mukemmel olsun

 

[Barons]

Hocam tekrar merhaba

Kendi dosyama monte ettiğimde 10.ncu satırda hata veriyor.
Hata olan kod:
Rs.Open "select distinct sum (Giriş_Tutar) From [database$] where (Cdate(Tarih)) < '" & CDate(DTPicker1.Value) & "' and (Banka) = '" & ComboBox1.Value & "'", Cn, 1, 1

kendi dosyama monte ederken herşey aynen aldım..sayfa adı,sütunlar birebir ama burada hata oluşuyor.Orjinal dosyada bakıyorum orada çalışıyor...
sadece değişen userform1, userform15 oldu ..birde dosya adı değişik...bu kadar...

hata kodu olan "on error resume next" ile geçeyim dedim...bunu yazınca verileri atıyor ancak devir hesaplanmıyor...

 

[Barons]

Hocam hatalı mesajlar ektedir.

 

[meslan]

Merhaba
Referansları konrol et.
Bu Kodu dene

Dim Cn, Rs As Object
Private Sub CommandButton1_Click()
Application.Calculation = xlCalculationManual
Set s1 = Sheets("Kasarapor")
s1.[a2:o65536].ClearContents
Set Cn = CreateObject("ADODB.Connection")
Set Rs = CreateObject("ADODB.Recordset")
Cn.Open _
"DRIVER={Microsoft Excel Driver (*.xls)};DBQ=" & _
    ThisWorkbook.FullName
Rs.Open "select distinct sum (Giriş_Tutar)  From [database$] where (Cdate(Tarih)) <  '" & CDate(DTPicker1.Value) & "' and (Banka) = '" & ComboBox1.Value & "'", Cn, 1, 1
If Rs(0) <> Empty Then Giren = CDbl(Rs(0))
Rs.Close
Rs.Open "select distinct sum (Çıkış_Tutar)  From [database$] where (Cdate(Tarih)) < '" & CDate(DTPicker1.Value) & "'and (Banka) = '" & ComboBox1.Value & "'", Cn, 1, 1
If Rs(0) <> Empty Then Cikan = CDbl(Rs(0))
Rs.Close
Cn.Close
If Cikan = Empty Then Cikan = 0
If Giren = Empty Then Giren = 0

Set s2 = Sheets("database")
s1.Cells(4, "r") = Giren - Cikan
If Giren - Cikan > 0 Then s1.Cells(2, "K") = Giren - Cikan: s1.Cells(2, 1) = 1
If Cikan - Giren > 0 Then s1.Cells(2, "L") = Cikan - Giren: s1.Cells(2, 1) = 1

c = s2.Range("A2:o" & s2.[a65536].End(3).Row).Value
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
 For i = 1 To UBound(c, 1)
    If CDate(c(i, 2)) >= CDate(DTPicker1.Value) And CDate(c(i, 2)) <= CDate(DTPicker2.Value) And c(i, 10) = ComboBox1.Value Then
        son = s1.[a65536].End(3).Row + 1
        For y = 1 To 12
            s1.Cells(son, y) = c(i, y)
        Next y
    End If
 Next i
End With
Application.Calculation = xlCalculationAutomatic
End Sub

Private Sub UserForm_Click()

End Sub

Private Sub UserForm_Initialize()
Application.ScreenUpdating = False
Set Cn = CreateObject("ADODB.Connection")
Set Rs = CreateObject("ADODB.Recordset")
Cn.Open "provider=microsoft.jet.oledb.4.0;data source = " & ThisWorkbook.FullName & _
";extended properties = ""excel 8.0;hdr=yes"""
Rs.Open "select distinct(Banka) From[database$]", Cn, 1, 1
Do While Not Rs.EOF
ComboBox1.AddItem Rs.fields(0).Value
Rs.movenext
Loop
Rs.Close
Cn.Close
Application.ScreenUpdating = True
End Sub

 

[Barons]

teşekkürler