• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Tarih Bazında Hesaplama

M

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
840
Excel Vers. ve Dili
Office 2016 TR
Arkadaşlar sizden bir ricam olacak
Ekli dosyada çek/senet tablomda yan tarafta "Durum" diye oluşturduğum tabloya aynı tarihte olanları tarih bazında hesaplamak için ne yapmam gerek.

Teşekkürler,
 

Ekli dosyalar

Dosyanız ektedir.
Kod: 
Option Base 1
Sub durum()
Dim z As Object, sat As Long, i As Long, myarr(), list()
Dim sh As Worksheet, n As Long, deg As String
Sheets("Dağılım").Select
Application.ScreenUpdating = False
Range("Y12:AC" & Rows.Count).ClearContents
Set sh = Sheets("Liste")
sat = sh.Cells(Rows.Count, "D").End(xlUp).Row
If sat < 5 Then
    MsgBox "Listede Veri yok.İşlem İptal Oldu!!", vbCritical, "U Y A R I"
    Set sh = Nothing
    Application.ScreenUpdating = True
    Exit Sub
End If
list = sh.Range("D5:G" & sat).Value
Set z = CreateObject("Scripting.dictionary")
ReDim myarr(1 To 5, 1 To UBound(list))
For i = 1 To UBound(list)
    deg = list(i, 1) & "-" & list(i, 4)
    If Not z.exists(deg) Then
        n = n + 1
        z.Add deg, n
        myarr(1, n) = list(i, 1)
    End If
    If list(i, 4) = "B" Then myarr(2, z.Item(deg)) = myarr(2, z.Item(deg)) + list(i, 3)
    If list(i, 4) = "T" Then myarr(3, z.Item(deg)) = myarr(3, z.Item(deg)) + list(i, 3)
    If list(i, 4) = "P" Then myarr(4, z.Item(deg)) = myarr(4, z.Item(deg)) + list(i, 3)
    If list(i, 4) = "F" Then myarr(5, z.Item(deg)) = myarr(5, z.Item(deg)) + list(i, 3)
Next i
If n > 0 Then
    Range("Y12").Resize(n, 5) = Application.Transpose(myarr)
End If
Application.ScreenUpdating = True
Set z = Nothing
Set sh = Nothing
Erase myarr
MsgBox "İşlem Tamamlanmıştır." & vbLf & "evrengizlen@hotmail.com"


End Sub
 

Ekli dosyalar

Sayın Orion1

Öncelikle zahmet ve uğraşınız için teşekkür ederim.

Ayrı ayrı teğilde, ilgili tarihte toplamını alabilirmiyiz acaba?
Mesela 23.08.2011 Borçlar toplamı,Takas toplamı,portföy toplamını
 
Dunya_' Alıntı:
Sayın Orion1

Öncelikle zahmet ve uğraşınız için teşekkür ederim.

Ayrı ayrı teğilde, ilgili tarihte toplamını alabilirmiyiz acaba?
Mesela 23.08.2011 Borçlar toplamı,Takas toplamı,portföy toplamını
Genişletmek için tıkla ...
Dosyanız ektedir.:cool:
Kod: 
Option Base 1
Sub durum()
Dim z As Object, sat As Long, i As Long, myarr(), list()
Dim sh As Worksheet, n As Long, deg As String
Sheets("Dağılım").Select
Application.ScreenUpdating = False
Range("Y12:AC" & Rows.Count).ClearContents
Set sh = Sheets("Liste")
sat = sh.Cells(Rows.Count, "D").End(xlUp).Row
If sat < 5 Then
    MsgBox "Listede Veri yok.İşlem İptal Oldu!!", vbCritical, "U Y A R I"
    Set sh = Nothing
    Application.ScreenUpdating = True
    Exit Sub
End If
list = sh.Range("D5:G" & sat).Value
Set z = CreateObject("Scripting.dictionary")
ReDim myarr(1 To 5, 1 To UBound(list))
For i = 1 To UBound(list)
    deg = list(i, 1)
    If Not z.exists(deg) Then
        n = n + 1
        z.Add deg, n
        myarr(1, n) = list(i, 1)
    End If
    If list(i, 4) = "B" Then myarr(2, z.Item(deg)) = myarr(2, z.Item(deg)) + list(i, 3)
    If list(i, 4) = "T" Then myarr(3, z.Item(deg)) = myarr(3, z.Item(deg)) + list(i, 3)
    If list(i, 4) = "P" Then myarr(4, z.Item(deg)) = myarr(4, z.Item(deg)) + list(i, 3)
    If list(i, 4) = "F" Then myarr(5, z.Item(deg)) = myarr(5, z.Item(deg)) + list(i, 3)
Next i
If n > 0 Then
    Range("Y12").Resize(n, 5) = Application.Transpose(myarr)
End If
Application.ScreenUpdating = True
Set z = Nothing
Set sh = Nothing
Erase myarr
MsgBox "İşlem Tamamlanmıştır." & vbLf & "evrengizlen@hotmail.com"


End Sub
 

Ekli dosyalar

Sayın Orion1

Hocam listeleme yaparken listedeki sadece D sutunu baz alıyor dolayısıyla tarihlerde işlem olmasada geliyor. G sutunundan B,T,P olanları yanlız aldırabilirmiyiz.

Ben sadece ne kadar verilmiş borç evraklarım var. Takasta ne kadar ve portföyde ne kadar var görmek istiyorum. Takastaki ile Portföyde olanların toplamı borç çeklerimi karşılıyormu analiz etmek istemiştim.
 

Ekli dosyalar

Dunya_' Alıntı:
Sayın Orion1

Hocam listeleme yaparken listedeki sadece D sutunu baz alıyor dolayısıyla tarihlerde işlem olmasada geliyor. G sutunundan B,T,P olanları yanlız aldırabilirmiyiz.

Ben sadece ne kadar verilmiş borç evraklarım var. Takasta ne kadar ve portföyde ne kadar var görmek istiyorum. Takastaki ile Portföyde olanların toplamı borç çeklerimi karşılıyormu analiz etmek istemiştim.
Genişletmek için tıkla ...
doayanız ektedir.:cool:
Kod: 
Option Base 1
Sub durum()
Dim z As Object, sat As Long, i As Long, myarr(), list()
Dim sh As Worksheet, n As Long, deg As String
Sheets("Dağılım").Select
Application.ScreenUpdating = False
Range("Y12:AC" & Rows.Count).ClearContents
Set sh = Sheets("Liste")
sat = sh.Cells(Rows.Count, "D").End(xlUp).Row
If sat < 5 Then
    MsgBox "Listede Veri yok.İşlem İptal Oldu!!", vbCritical, "U Y A R I"
    Set sh = Nothing
    Application.ScreenUpdating = True
    Exit Sub
End If
list = sh.Range("D5:G" & sat).Value
Set z = CreateObject("Scripting.dictionary")
ReDim myarr(1 To 5, 1 To UBound(list))
For i = 1 To UBound(list)
    If list(i, 4) = "B" Or list(i, 4) = "P" Or list(i, 4) = "T" Then
        deg = list(i, 1)
        If Not z.exists(deg) Then
            n = n + 1
            z.Add deg, n
            myarr(1, n) = list(i, 1)
        End If
        If list(i, 4) = "B" Then myarr(2, z.Item(deg)) = myarr(2, z.Item(deg)) + list(i, 3)
        If list(i, 4) = "T" Then myarr(3, z.Item(deg)) = myarr(3, z.Item(deg)) + list(i, 3)
        If list(i, 4) = "P" Then myarr(4, z.Item(deg)) = myarr(4, z.Item(deg)) + list(i, 3)
    End If
Next i
If n > 0 Then
    Range("Y12").Resize(n, 5) = Application.Transpose(myarr)
End If
Application.ScreenUpdating = True
Set z = Nothing
Set sh = Nothing
Erase myarr
MsgBox "İşlem Tamamlanmıştır." & vbLf & "evrengizlen@hotmail.com"


End Sub
 

Ekli dosyalar

Orion1' Alıntı:
doayanız ektedir.:cool:
Kod: 
Option Base 1
Sub durum()
Dim z As Object, sat As Long, i As Long, myarr(), list()
Dim sh As Worksheet, n As Long, deg As String
Sheets("Dağılım").Select
Application.ScreenUpdating = False
Range("Y12:AC" & Rows.Count).ClearContents
Set sh = Sheets("Liste")
sat = sh.Cells(Rows.Count, "D").End(xlUp).Row
If sat < 5 Then
    MsgBox "Listede Veri yok.İşlem İptal Oldu!!", vbCritical, "U Y A R I"
    Set sh = Nothing
    Application.ScreenUpdating = True
    Exit Sub
End If
list = sh.Range("D5:G" & sat).Value
Set z = CreateObject("Scripting.dictionary")
ReDim myarr(1 To 5, 1 To UBound(list))
For i = 1 To UBound(list)
    If list(i, 4) = "B" Or list(i, 4) = "P" Or list(i, 4) = "T" Then
        deg = list(i, 1)
        If Not z.exists(deg) Then
            n = n + 1
            z.Add deg, n
            myarr(1, n) = list(i, 1)
        End If
        If list(i, 4) = "B" Then myarr(2, z.Item(deg)) = myarr(2, z.Item(deg)) + list(i, 3)
        If list(i, 4) = "T" Then myarr(3, z.Item(deg)) = myarr(3, z.Item(deg)) + list(i, 3)
        If list(i, 4) = "P" Then myarr(4, z.Item(deg)) = myarr(4, z.Item(deg)) + list(i, 3)
    End If
Next i
If n > 0 Then
    Range("Y12").Resize(n, 5) = Application.Transpose(myarr)
End If
Application.ScreenUpdating = True
Set z = Nothing
Set sh = Nothing
Erase myarr
MsgBox "İşlem Tamamlanmıştır." & vbLf & "evrengizlen@hotmail.com"


End Sub
Genişletmek için tıkla ...

Hocam,

Zahmet ve uğraşınızdan dolayı çok teşekkür ederim.Elinize Sağlık.
 
Sayın Orion1

Hocam,

Son bir ricam daha olacaktı. Verdiğiniz kodlara hücre boş ise sarı dolgu olması için ne yapmam gerek ? Mesela 28.08.2012 Takasta ,portföyde ve borç kısmında tutar yoksa dolgu sarı olsa iyi olur.
 
Dunya_' Alıntı:
Sayın Orion1

Hocam,

Son bir ricam daha olacaktı. Verdiğiniz kodlara hücre boş ise sarı dolgu olması için ne yapmam gerek ? Mesela 28.08.2012 Takasta ,portföyde ve borç kısmında tutar yoksa dolgu sarı olsa iyi olur.
Genişletmek için tıkla ...
Bunu anlamadım.dosya üzertinde gösterip orada açıklamasını yazrsanız daha anlaşılır olacaktır.:cool:
 
Dunya_' Alıntı:
Sayın Orion1
Hocam,
Açıklama dosya içerisinde.
Genişletmek için tıkla ...
Dosyanız ektedir.:cool:
Kod: 
Option Base 1
Sub durum()
Dim z As Object, sat As Long, i As Long, myarr(), list()
Dim sh As Worksheet, n As Long, deg As String, hcr As Range
Sheets("Dağılım").Select
Application.ScreenUpdating = False
Range("Y12:AC" & Rows.Count).Clear
Set sh = Sheets("Liste")
sat = sh.Cells(Rows.Count, "D").End(xlUp).Row
If sat < 5 Then
    MsgBox "Listede Veri yok.İşlem İptal Oldu!!", vbCritical, "U Y A R I"
    Set sh = Nothing
    Application.ScreenUpdating = True
    Exit Sub
End If
list = sh.Range("D5:G" & sat).Value
Set z = CreateObject("Scripting.dictionary")
ReDim myarr(1 To 5, 1 To UBound(list))
For i = 1 To UBound(list)
    If list(i, 4) = "B" Or list(i, 4) = "P" Or list(i, 4) = "T" Then
        deg = list(i, 1)
        If Not z.exists(deg) Then
            n = n + 1
            z.Add deg, n
            myarr(1, n) = list(i, 1)
        End If
        If list(i, 4) = "B" Then myarr(2, z.Item(deg)) = myarr(2, z.Item(deg)) + list(i, 3)
        If list(i, 4) = "T" Then myarr(3, z.Item(deg)) = myarr(3, z.Item(deg)) + list(i, 3)
        If list(i, 4) = "P" Then myarr(4, z.Item(deg)) = myarr(4, z.Item(deg)) + list(i, 3)
    End If
Next i
If n > 0 Then
    Range("Y12").Resize(n, 5) = Application.Transpose(myarr)
End If
Set z = Nothing
Set sh = Nothing
Erase myarr
sat = Cells(Rows.Count, "Y").End(xlUp).Row
If sat < 12 Then Exit Sub
For Each hcr In Range("Z12:AB" & sat)
    If hcr.Value = "" Then hcr.Interior.ColorIndex = 15
Next
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlanmıştır." & vbLf & "evrengizlen@hotmail.com"
End Sub
 

Ekli dosyalar

Hocam,

Güzel olmuş eline sağlık ama karakter büyüklüğünü her defasında 8 yapıyorum makroyu çalıştırdığımda karakter büyüklüğü 11 oluyor. Bunu 8 yapabilirmiyiz. Temizle butonuna basıldığında Hücre dolguları temizlenmiyor.
 
Son düzenleme:
Dunya_' Alıntı:
Hocam,

Güzel olmuş eline sağlık ama karakter büyüklüğünü her defasında 8 yapıyorum makroyu çalıştırdığımda karakter büyüklüğü 11 oluyor. Bunu 8 yapabilirmiyiz. Temizle butonuna basıldığında Hücre dolguları temizlenmiyor.
Genişletmek için tıkla ...
Dosyanız ektedir.:cool:
Kod: 
Option Base 1
Sub durum()
Dim z As Object, sat As Long, i As Long, myarr(), list()
Dim sh As Worksheet, n As Long, deg As String, hcr As Range
Sheets("Dağılım").Select
Application.ScreenUpdating = False
Range("Y12:AC" & Rows.Count).Clear
Range("Y12:AC" & Rows.Count).Font.Size = 8
Set sh = Sheets("Liste")
sat = sh.Cells(Rows.Count, "D").End(xlUp).Row
If sat < 5 Then
    MsgBox "Listede Veri yok.İşlem İptal Oldu!!", vbCritical, "U Y A R I"
    Set sh = Nothing
    Application.ScreenUpdating = True
    Exit Sub
End If
list = sh.Range("D5:G" & sat).Value
Set z = CreateObject("Scripting.dictionary")
ReDim myarr(1 To 5, 1 To UBound(list))
For i = 1 To UBound(list)
    If list(i, 4) = "B" Or list(i, 4) = "P" Or list(i, 4) = "T" Then
        deg = list(i, 1)
        If Not z.exists(deg) Then
            n = n + 1
            z.Add deg, n
            myarr(1, n) = list(i, 1)
        End If
        If list(i, 4) = "B" Then myarr(2, z.Item(deg)) = myarr(2, z.Item(deg)) + list(i, 3)
        If list(i, 4) = "T" Then myarr(3, z.Item(deg)) = myarr(3, z.Item(deg)) + list(i, 3)
        If list(i, 4) = "P" Then myarr(4, z.Item(deg)) = myarr(4, z.Item(deg)) + list(i, 3)
    End If
Next i
If n > 0 Then
    Range("Y12").Resize(n, 5) = Application.Transpose(myarr)
End If
Set z = Nothing
Set sh = Nothing
Erase myarr
sat = Cells(Rows.Count, "Y").End(xlUp).Row
If sat < 12 Then Exit Sub
For Each hcr In Range("Z12:AB" & sat)
    If hcr.Value = "" Then hcr.Interior.ColorIndex = 15
Next
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlanmıştır." & vbLf & "evrengizlen@hotmail.com"
End Sub
 

Ekli dosyalar

Merhabalar ,

Daha önce yardımlarınızla beraber oluşturduğumuz tabloda değişiklik yapmak zorundayım. Çek senet adetleri oldukça fazla olduğundan, her gün kullandığımız paket programdan kopyala yapıştır yapıyorum. Hem zaman aldığından ve hemde yanlış olmaya sebebiyet verdiğinden, verileri sql den excele otomatik almaya karar verdim. Ekli tabloda yapmak istediklerimi kısaca özetledim. Yardımlarınızı bekler,şimdiden teşekkürlerimi sunarım.
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst