Lisans Takibi ve Filtrelenmesi

[systemmania]

Merhabalar,

Yapmak isteyipte yapamamış olduğum konu aşağıda anlattığım gibidir.Forum sayfamızda çok dosya inceledim fakat isteğimle alakalı bir dökümana ulaşamadım veya gözlemleyemedim.Eğer talebimle alakalı çözüm sunabilirseniz çok memnun olurum.

Yapmak istediğim :

0 ve 0 dan büyük olan değerleri Lisansı Bitenler sayfasına kopyalamalı ve Cihazlar listesi sabit kalmalı.
-30 dan -1 e kadar olan değerleri Lisansı Bitecekler sayfasına kopyalamalı ve Cihazlar listesi sabit kalmalı.

Tabi iki listede (Lisansı Bitenler ve Bitecekler) her butona basıldığında o günkü güne göre hesaplanarak güncellenmeli !

Şimdiden yardımlarınız için teşekkürler.

Not : Dosya ektedir.

 

[Orion1]

Dosyanız ektedir.

Sub biten_aktar()
Dim kayit
Application.ScreenUpdating = False
kayit = lisans(Sheets("Lisansı Bitenler"))
Application.ScreenUpdating = True
End Sub
Sub bitecekler()
Dim kayit
Application.ScreenUpdating = False
kayit = lisans(Sheets("Lisansı Bitecekler"))
Application.ScreenUpdating = True

End Sub
Function lisans(sh As Worksheet)
Dim sont As Long, i As Long, sat As Long
sh.Range("A2:D65536").ClearContents
son = Cells(65536, "C").End(xlUp).Row
sat = 2
If sh.Name = "Lisansı Bitenler" Then
    For i = 3 To son
        If Cells(i, "D").Value >= 0 Then
            sh.Range("A" & sat & ":D" & sat).Value = _
            Range("A" & i & ":D" & i).Value
            sat = sat + 1
        End If
    Next i
    MsgBox "Lisansı Bitenler aktarıldı." & vbLf & vbLf & _
    "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
ElseIf sh.Name = "Lisansı Bitecekler" Then
    For i = 3 To son
        If Cells(i, "D").Value <= -1 And Cells(i, "D").Value >= -30 Then
            sh.Range("A" & sat & ":D" & sat).Value = _
            Range("A" & i & ":D" & i).Value
            sat = sat + 1
        End If
    Next i
    MsgBox "Lisansı Bitecekler aktarıldı." & vbLf & vbLf & _
    "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End If
End Function

 

[systemmania]

Harikasınız.Bu yardımlarınız için çok teşekkür ederim.Kodları hemen inceledim ve sadece

-30 dan -1 e kadar olan değerleri Lisansı Bitecekler sayfasına kopyalamalı

demiştim fakat - 'ye düşen tüm değerleri almakta.Tek eksiğimiz bu.

Tekrardan bu hızlı cevabınız için teşekkürler.

 

[Orion1]

Harikasınız.Bu yardımlarınız için çok teşekkür ederim.Kodları hemen inceledim ve sadece

-30 dan -1 e kadar olan değerleri Lisansı Bitecekler sayfasına kopyalamalı

demiştim fakat - 'ye düşen tüm değerleri almakta.Tek eksiğimiz bu.

Tekrardan bu hızlı cevabınız için teşekkürler.

Evet onu atlamaışım.
Dosyayı güncelledim.2 numaralı mesajdan indirebilirsiniz.

 

[systemmania]

Gayet güzel oldu.Emeğinize sağlık çok teşekkürler.