Koşullu Süz

[noxious]

Elimde daha önceden ustalarımın yardımı ile yapmış olduğum bir çalışma var

http://www.excel.web.tr/showthread.php?t=40070&highlight=ko%FEullu+s%FCz

Burda yapılan işlem isme göre sorgu yaptırıyor.

Bu işlem dışında birde dolu hücrelerin süzme işlemini yapılması lazım forumda örnek aradım bulamadım. Yukarıdaki linkte hocalarımla hazırladığımız kodları uyarlamaya çalıştım beceremedim. Ben Bu işi öğrenemedimmi ne

Kısacası istenilen şey tarih aralığı işaretlendikten sonra E3:H65500 aralığında sadece dolu hücreler (Hücrelerden sadece bir tanesi bile dolu olsa gözükecek) kalacak şekilde süz işlemi yapılması

Not tek hücrede yapıyorum ama 4 ayrı hücreyi aynı anda denediğimde E hücresinde, F veya .... hücresinde bir boşluk oldumu o satır otomatikman süzden nasibini alıyor. E ile H arasında tek bir hücrenin dolu olması görünmesi açısından yeterli

 

[Orion1]

Ekli dosyayı inceleyiniz.
Textbox'a yazılan kodları iptal ettim.

Private Sub CommandButton1_Click()
Dim sat, i As Long, k As Byte, adrs As String
ListBox1.RowSource = ""
For i = 3 To Cells(65536, "D").End(xlUp).Row
    adrs = Range(Cells(i, "E"), Cells(i, "H")).Address
    If WorksheetFunction.CountA(Range(adrs)) > 0 Then
        If CLng(CDate(Cells(i, "D").Value)) >= CLng(CDate(Calendar1.Value)) _
        And CLng(CDate(Cells(i, "D").Value)) <= CLng(CDate(Calendar2.Value)) Then
            ListBox1.AddItem
            For k = 0 To 7
                ListBox1.Column(k, sat) = Cells(i, k + 1).Value
            Next k
            sat = sat + 1
        End If
    End If
Next i
TextBox1.Value = ListBox1.ListCount - 1
End Sub

Private Sub UserForm_Initialize()
Sheets("Denetlemeler").Select
ListBox1.ColumnCount = 8
ListBox1.RowSource = "A3:H" & Cells(65536, "D").End(xlUp).Row
End Sub

 

[noxious]

Sayın Orion2 Hocam Sağol

Mümkünse Kodların açıklamalarına yer verebilirmisiniz. Kodları incelediğimde bir çoğunu anlıyorum. İstediğim değişiklikleri yapabiliyorum ama karşılarında açıklama olsa daha kolay işlem yaparız.

Birde son olarak benim çalışmamda A2 ile AH arası veri dolu, tarih I2 sütunundan başlıyor ve süz işlemi L, M, N ve O (L2:O65500) hücreleri arasında yapılacak ve aşağıdaki kodlarda yer değişikliği yaptığımda hata ile karşılaşıyorum. Sizin örneğiniz ise sorunsuz çalışıyor

Private Sub CommandButton1_Click()
Dim sat, i As Long, k As Byte, adrs As String
ListBox1.RowSource = ""
For i = 3 To Cells(65536, "D").End(xlUp).Row
    adrs = Range(Cells(i, "E"), Cells(i, "H")).Address
    If WorksheetFunction.CountA(Range(adrs)) > 0 Then
        If CLng(CDate(Cells(i, "D").Value)) >= CLng(CDate(Calendar1.Value)) _
        And CLng(CDate(Cells(i, "D").Value)) <= CLng(CDate(Calendar2.Value)) Then
            ListBox1.AddItem
            For k = 0 To 7
                ListBox1.Column(k, sat) = Cells(i, k + 1).Value
            Next k
            sat = sat + 1
        End If
    End If
Next i
TextBox1.Value = ListBox1.ListCount - 1
End Sub

Private Sub TextBox1_Change()
Exit Sub
Dim sh As Worksheet
Dim bul As Range, rg As Range
Dim y As Integer, satir As Integer, x As Integer
Dim i As Integer, j As Integer
Dim arrSatir()
Dim arrveri()
Dim adres As String
If Trim(TextBox1) = Empty Then: ListBox1.Clear: TextBox2 = Empty: Exit Sub
Set sh = Sheets("Denetlemeler")
Set rg = sh.Range("E3:H65500")
 Selection.AutoFilter
[A2] = Calendar1
 Sheets("Denetlemeler").Range("a3").AutoFilter Field:=4, Criteria1:=">=" & CDbl(Calendar1), Operator:=xlAnd _
        , Criteria2:="<=" & CDbl(Calendar2)
[D2] = Calendar2
 Sheets("Denetlemeler").Range("a3").AutoFilter Field:=4, Criteria1:=">=" & CDbl(Calendar1), Operator:=xlAnd _
        , Criteria2:="<=" & CDbl(Calendar2)
Set sh = Nothing
End Sub

ListBox içerisinde görüntüleme

Private Sub UserForm_Initialize()
Sheets("Denetlemeler").Select
ListBox1.ColumnCount = 8
ListBox1.RowSource = "A3:H" & Cells(65536, "D").End(xlUp).Row
End Sub

 

[Orion1]

Aşağıdaki kodları deneyiniz.

Private Sub CommandButton1_Click()
Dim sat, i As Long, k As Byte, adrs As String
ListBox1.RowSource = ""
For i = 2 To Cells(65536, "I").End(xlUp).Row
    adrs = Range(Cells(i, "L"), Cells(i, "O")).Address
    If WorksheetFunction.CountA(Range(adrs)) > 0 Then
        If CLng(CDate(Cells(i, "I").Value)) >= CLng(CDate(Calendar1.Value)) _
        And CLng(CDate(Cells(i, "I").Value)) <= CLng(CDate(Calendar2.Value)) Then
            ListBox1.AddItem
            For k = 0 To 7
                ListBox1.Column(k, sat) = Cells(i, k + 9).Value
            Next k
            sat = sat + 1
        End If
    End If
Next i
TextBox1.Value = ListBox1.ListCount - 1
End Sub

 

[noxious]

Hocam o sorunu hallettim
ancak TextBox Change ve Userform İnitializede sorun oluşuyor. aşağıdaki gibi değiştirdim ama bu sefer ListBox da tarih başa geliyor yani I dan P hücre bilgisine kadar dahası yok. Süz işlemi bitince A2 den AH ye kadar olanları alması lazım
son olarakta UserForm açıldığında TextBox içeriği dolmasa sadece süz işlemine tıkladığımızda dolsa çünkü şu an yaklaşık 2500 satır dolu ve her gün yaklaşık 200 satır ilave oluyor yani bilgiler çoğaldıkça ListBox içerisindeki bilgi ilk açılışta süreyi uzatmazmı

Private Sub TextBox1_Change()
Private Sub TextBox1_Change()
Dim sh As Worksheet
Dim bul As Range, rg As Range
Dim y As Integer, satir As Integer, x As Integer
Dim i As Integer, j As Integer
Dim arrSatir()
Dim arrveri()
Dim adres As String
If Trim(TextBox1) = Empty Then: ListBox1.Clear: TextBox2 = Empty: Exit Sub
Set sh = Sheets("Denetlemeler")
Set rg = sh.Range("L2:O65500")
 Selection.AutoFilter
[A2] = Calendar1
 Sheets("Denetlemeler").Range("a2").AutoFilter Field:=9, Criteria1:=">=" & CDbl(Calendar1), Operator:=xlAnd _
        , Criteria2:="<=" & CDbl(Calendar2)
[D2] = Calendar2
 Sheets("Denetlemeler").Range("a2").AutoFilter Field:=9, Criteria1:=">=" & CDbl(Calendar1), Operator:=xlAnd _
        , Criteria2:="<=" & CDbl(Calendar2)
Set sh = Nothing
End Sub

Private Sub UserForm_Initialize()
Sheets("Denetlemeler").Select
ListBox1.ColumnCount = 33
ListBox1.RowSource = "A2:AH" & Cells(65536, "I").End(xlUp).Row
End Sub

 

[Orion1]

Userform'un initialize olayında listbox'ın RowSource metodu ile veriler alınmakta.
Bu metodla bu miktardaki verileri almak hiç zaman almaz.Döngüye girip additem yöntemi ile verileri almak zaman alır.Süz butonunun istediğiniz gibi diğer verileride almasını istiyorsanız,Küçük bir örnek dosya yollayınız.

 

[noxious]

Hocam bazı bölümleri silmek zorunda kaldım kusura bakmayın özel bilgiler içeriyordu sayfada şifre sorarsa şifre 543216

 

[Orion1]

Dağa önce E:H aralığındaki hücrelerin dolu olup olmadığı sorgulanıyordu.Şimdi hangi sütun aralığı sorgulanıcak?

 

[Orion1]

L:Z arlığının dolu olup olmadığını sorgulayarak işlem yapıyor.
Ekli dosyayı inceleyiniz.

Private Sub CommandButton1_Click()
Dim i As Long, k As Byte, adrs As String, a As Long
ListBox1.RowSource = ""
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
ReDim myarr(1 To 34, 1 To 1)
For i = 2 To Cells(65536, "I").End(xlUp).Row
    adrs = Range(Cells(i, "L"), Cells(i, "Z")).Address
    If WorksheetFunction.CountA(Range(adrs)) > 0 Then
        If CLng(CDate(Cells(i, "I").Value)) >= CLng(CDate(Calendar1.Value)) _
        And CLng(CDate(Cells(i, "I").Value)) <= CLng(CDate(Calendar2.Value)) Then
            a = a + 1
            ReDim Preserve myarr(1 To 34, 1 To a)
            For k = 1 To 34
                myarr(k, a) = Cells(i, k).Value
            Next k
        End If
    End If
Next i
ListBox1.Column = myarr
Erase myarr
Label5.Caption = ListBox1.ListCount - 1
End Sub

 

[noxious]

Hocam ellerine sağlık şimdi tamam geri kalan düzenlemeleri ben yaparım. Allah razı olsun.

bir sorun vardı gece olması sebebiyle gözünden kaçmış olabilir.
Toplam sayıyı göstermek için Label eklemişsin
Label5.Caption = ListBox1.ListCount - 1 (-1 olduğunda eksik çıktığı için -1 i sildim)

ayrıca
TextBox1 = ListBox1.ListCount - 1 eklenmemişti onu ekledim bundada -1 olduğu için bir eksik çıkıyordu onuda düzelttim. Tekrar teşekkürler


Not: TextBox1 içeriğini yukarıdaki gibi düzenleyince otomatik sayılandırmanın başladığı A2 hücre değeri bozulduğu için iptal ettim. Sayı görüntüsünü Label içerisinde almak daha mantıklı

 

[noxious]

Label5.Caption = ListBox1.ListCount - 1 içerisine süz sonucu kalanların sayısı gözüküyor

bir başka Label eklesek
Label6=Süz sonucu L sütununda kalan sayıların toplamını,
Label7=Süz sonucu M sütununda kalan sayıların toplamını .........
Label20=Süz sonucu Z sütununda kalan sayıların toplamını gösterse mümkünmü acaba

 

[Orion1]

Ekli doyayaı inceleyiniz.

Private Sub CommandButton1_Click()
Dim i As Long, k As Byte, adrs As String, a As Long
Dim L_sut, M_sut, Z_sut As Double
ListBox1.RowSource = ""
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
ReDim myarr(1 To 34, 1 To 1)
For i = 2 To Cells(65536, "I").End(xlUp).Row
    adrs = Range(Cells(i, "L"), Cells(i, "Z")).Address
    If WorksheetFunction.CountA(Range(adrs)) > 0 Then
        If CLng(CDate(Cells(i, "I").Value)) >= CLng(CDate(Calendar1.Value)) _
        And CLng(CDate(Cells(i, "I").Value)) <= CLng(CDate(Calendar2.Value)) Then
            a = a + 1
            ReDim Preserve myarr(1 To 34, 1 To a)
            For k = 1 To 34
                If k = 9 Then
                    myarr(k, a) = Format(Cells(i, k).Value, "dd.mm.yyyy")
                    Else
                    myarr(k, a) = Cells(i, k).Value
                End If
            Next k
            L_sut = L_sut + Cells(i, "L").Value
            M_sut = M_sut + Cells(i, "M").Value
            Z_sut = Z_sut + Cells(i, "Z").Value
        End If
    End If
Next i
ListBox1.Column = myarr
Erase myarr
Label5.Caption = ListBox1.ListCount
Label7.Caption = L_sut
Label9.Caption = M_sut
Label11.Caption = Z_sut
End Sub

Private Sub UserForm_Initialize()
Sheets("Denetlemeler").Select
ListBox1.ColumnCount = 34
ListBox1.RowSource = "A2:AH" & Cells(65536, "I").End(xlUp).Row
Label5.Caption = ListBox1.ListCount
Label7.Caption = WorksheetFunction.Sum(Range("L2:L" & Cells(65536, "I").End(xlUp).Row))
Label9.Caption = WorksheetFunction.Sum(Range("M2:M" & Cells(65536, "I").End(xlUp).Row))
Label11.Caption = WorksheetFunction.Sum(Range("Z2:Z" & Cells(65536, "I").End(xlUp).Row))
End Sub

 

[noxious]

Hocam sağol tekrar Allah razı olsun irdeledikçe yeni yeni şeyler öğreniyorum

ekli dosyama gönderdiğiniz kodu daha eklemedim ama ekleyeceğim. (İnternetimde sıkıntı var kesilip duruyor)

Bu arada bir sorunum daha var

ekli dosyada MemurBulForm diye bir sorgu var bu sorgulamada isim için harflere bastıkça ilgili aralıkta sorgulama yapıyor ve bu işlem çok uzun sürüyor. bir buton ekliyerek ismi yazdıktan (örneğin hücrede Ahmet VELİOĞLU yazdığını varsayarak Ahmet diye kısa veya Ahmet VELİOĞLU diye uzun yazıp yani her iki alternatiftede yazabiliriz sonra arama yaptırsak (bu arada sorgudan sonra ListBox içerisinde hücre sıralaması değişiyor sondaki bir kaç hücre 2., 3., 4., ve 5. sıraya geliyor. bu değişiklik kalmalı). İsim ile ilgili bir süz bulamazsa aradığınız isim yok diye uyarsa

son olarakta sorgu yaptıktan sonra A2 hücresi ile D2 hücresi bilgi kaybına uğruyor ne yaptıysam çözemedim

Sayfa şifreleri 543216

 

[Orion1]

Hocam sağol tekrar Allah razı olsun irdeledikçe yeni yeni şeyler öğreniyorum

ekli dosyama gönderdiğiniz kodu daha eklemedim ama ekleyeceğim. (İnternetimde sıkıntı var kesilip duruyor)

Bu arada bir sorunum daha var

son olarakta sorgu yaptıktan sonra A2 hücresi ile D2 hücresi bilgi kaybına uğruyor ne yaptıysam çözemedim

Sayfa şifreleri 543216

Bununla ilgili sorun çözüldü.
Ekli dosyayı inceleyiniz.

 

[noxious]

Sayın Orion Hocam Hızır gibisiniz Allah Razı olsun.

Bu arada gönderdiğiniz kodlar gerçekten çok hızlı eski kodlarımı tümüyle sizin kodlar ile değiştirdim.

Birtek bu son süzmeye karışmadım.

Bu arada hocam harf girdikçe döngü başlıyacağına biz sadece ismi yazsak sonra buton vasıtası ile aratsak malum her girilen harfte süz baştan tekrarlama yapıyor ve yavaş makinalarda uzun zaman bekletiyor
ve
son olarakta aradığımız isim yoksa bir uyarı verse aradığınız kriterde isim yok diye

 

[Orion1]

Sayın Orion Hocam Hızır gibisiniz Allah Razı olsun.

Bu arada gönderdiğiniz kodlar gerçekten çok hızlı eski kodlarımı tümüyle sizin kodlar ile değiştirdim.

Birtek bu son süzmeye karışmadım.

Bu arada hocam harf girdikçe döngü başlıyacağına biz sadece ismi yazsak sonra buton vasıtası ile aratsak malum her girilen harfte süz baştan tekrarlama yapıyor ve yavaş makinalarda uzun zaman bekletiyor
ve
son olarakta aradığımız isim yoksa bir uyarı verse aradığınız kriterde isim yok diye

Memur bu formunda BUL-Süz butonuna basınız.
Ekli dosyayı inceleyiniz.

 

[noxious]

Hocam sistem tam istediğim gibi ancak arama kriteri Set rg = sh.Range("AA1:AH65500") arasında gözükmesine rağmen ne listedeki isimleri nede yeni yazdığım isimleri bulamıyor. Yapılan aramaların hepsine "" bulunamadı diyor

 

[noxious]

Hocam çok çok özür diliyorum hata benden kaynaklanıyormuş kodlarda sorun yok (Dün yağmurda kaldım bu gün çok kötü hastayım ve kendimi veremiyorum)

Bir saattir tarih aralığını işaretlemeden süz yaptırıyorum jeton sonradan düştü

 

[Orion1]

Hocam çok çok özür diliyorum hata benden kaynaklanıyormuş kodlarda sorun yok (Dün yağmurda kaldım bu gün çok kötü hastayım ve kendimi veremiyorum)

Bir saattir tarih aralığını işaretlemeden süz yaptırıyorum jeton sonradan düştü

Geçmiş olsun.
Ben sizin kodlarınızı dfeğiştirmedim.
Sadece mesaj ilave ettim ve 2nci satır sorgulamasını ilave ettim.
Ve A1 ile D1 hücrelerinde boşluk oluşuyordu onu hallettim.
Şimdi listbox'ta listeleme yapıyormu?
Ben listeleyemedimde.

 

[noxious]

Sağolun Hocam
Dediğim gibi hata benden kaynaklanıyormuş tarih aralığını girmediğim için.
Listelemede sorun yok herşey mükemmel elleriniz ve aklınız dert görmesin mükemmel oldu şimdi işlemler daha seri bir şekilde halloluyor. Ben bir sorun göremedim tekrar Teşekkürler.