• DİKKAT

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

Soru Listbox İle İki Tarih Aralığını Süzme Dış Ortama Aktarma Örneği

T

TURKOLOG

Altın Üye
Katılım
13 Kasım 2008
Mesajlar
745
Excel Vers. ve Dili
2016 64 TR
Herkese merhaba
Elinde iki tarih aralığını süzen bir listbox örneği olan var mı acaba.
Güzel bir şey yapmak istiyorum ama iki tarih aralığındaki kayıtları süzüp Listboxta getirmek isityorum.
Listboxtaki veriyi dış ortama word excel pdf olarak çıkarmak istiyorum. Elinde örnek olan paylaşabilir mi rica etsem.
 
Bu konuda elinde örnek olan hiç mi yok
 
Merhaba
Ek dosyayı denermisiniz?
Filtrelenenleri "pdf" olarak kaydeder,
we.tl

tarih.rar

1 file sent via WeTransfer, the simplest way to send your files around the world
we.tl we.tl
 
Değerli Hocam çok teşekkür ederim. Dosyayı pazartesi günü deneyip size dönüş yapacağım. Yardımlarınız için tekrar tekrar teşekkür ederim size. Allah razı olsun sizden.

Tam olarak yapmak istediğim şu.:
Aslında dosyayı siz biliyorsunuz pasif işlemeleri userformunundaki listboxu sicil, isim, rütbe, büro olarak txtara_Change makrosu altinda süzüyorum. Ama iki tarih aralığında da 15.01.2020 dahil 15.02.2020 dahil süzerek listboxtaki veriyi dış ortama pdf olur word olur bir de excel olarak Sabitler B10 daki yola göre dışarıya aktarmak istiyorum .
Yine listboxu veriyi çektiği sayfanın en alt dolu satırı Listboxta en üstte olacak şekilde sıralamak istiyorum .
 
Sayın @PLİNT malesef olmadı
Su iKi kodu denedim olmadı
Kod: 
Private Sub Süz_Click()

  With Sayfa22

        Dim i As Long

For i = 2 To Range("a65536").End(3).Row

    If CLng(CDate(Cells(i, "G").Value)) >= CLng(CDate(TextBox23.Value)) And _

        CLng(CDate(Cells(i, "H").Value)) <= CLng(CDate(TextBox24.Value)) Then

        

        

          

    txtSira.Text = ListBox1.Column(0)

    txtSicili.Text = ListBox1.Column(1)

    txtAdi.Text = ListBox1.Column(2)

    txtSoyadi.Text = ListBox1.Column(3)

    txtRutbesi.Text = ListBox1.Column(4)

    txtBurosu.Text = ListBox1.Column(5)

    txtGidis.Text = ListBox1.Column(6)

    txtDonus.Text = ListBox1.Column(7)

    txtAciklama.Text = ListBox1.Column(8)

    TextBox8.Text = ListBox1.Column(9)

    TextBox9.Text = ListBox1.Column(10)

    TextBox10.Text = ListBox1.Column(11)

    TextBox11.Text = ListBox1.Column(12)

    TextBox12.Text = ListBox1.Column(13)

    TextBox13.Text = ListBox1.Column(14)

              

            

    End If

Next i

 

    

   End Sub


Bir de bu kodu denedim
Olmadı
 
Kod: 
Private Sub Süz_Click()

With Sayfa22

If TextBox23.Value = "" Or TextBox24.Value = "" Then

MsgBox "Lütfen Tarih seçiniz", vbCritical, "TARİH SEÇME HATASI"

Exit Sub

End If

Label1.Caption = TextBox23.Value

Label2.Caption = TextBox24.Value

Dim i As Long

ListBox1.Clear

For i = 2 To Range("a65536").End(3).Row

If CLng(CDate(Cells(i, "G").Value)) >= CLng(CDate(TextBox23.Value)) And CLng(CDate(Cells(i, "H").Value)) <= CLng(CDate(TextBox24.Value)) Then

With ListBox1

    .AddItem Format(Cells(i, 1).Value, "dd.mm.yyyy")

    .List(.ListCount - 1, 1) = Cells(i, 2).Value

    .List(.ListCount - 1, 2) = Cells(i, 3).Value

    .List(.ListCount - 1, 3) = Cells(i, 4).Value

    .List(.ListCount - 1, 4) = Cells(i, 5).Value

    .List(.ListCount - 1, 5) = Cells(i, 6).Value

    .List(.ListCount - 1, 6) = Cells(i, 7).Value

    .List(.ListCount - 1, 7) = Cells(i, 8).Value

    .List(.ListCount - 1, 9) = Cells(i, 10).Value

    .List(.ListCount - 1, 10) = Cells(i, 11).Value

    .List(.ListCount - 1, 11) = Cells(i, 12).Value

    .List(.ListCount - 1, 12) = Cells(i, 13).Value

    .List(.ListCount - 1, 13) = Cells(i, 14).Value

    .List(.ListCount - 1, 14) = Cells(i, 15).Value

  

    

    

    

    

  

    

End With

End If

Next i

i = Empty

 

    End With

   End Sub
 
Merhaba
Son mesajınızdaki kodları aşağıdaki gibi deneyelim
Kod: 
Private Sub Süz_Click()

With Sayfa22
If TextBox23.Value = "" Or TextBox24.Value = "" Then
MsgBox "Lütfen Tarih seçiniz", vbCritical, "TARİH SEÇME HATASI"
Exit Sub
End If
Label1.Caption = TextBox23.Value
Label2.Caption = TextBox24.Value
Dim i As Long
Dim list As Variant, satır As Long, x As Long
ListBox1.Clear
ListBox1.ColumnCount = 15
ReDim list(1 To 15, 1 To 1)
For i = 2 To .Range("a65536").End(3).Row
If IsDate(.Cells(i, "G").Text) = True And IsDate(.Cells(i, "H").Text) = True And IsDate(TextBox23.Text) = True And IsDate(TextBox24.Text) = True Then
If CDate(.Cells(i, "G").Text) >= CDate(TextBox23.Text) And CDate(.Cells(i, "H").Text) <= CDate(TextBox24.Text) Then
satır = satır + 1
ReDim Preserve list(1 To 15, 1 To satır)
For x = 1 To 15
list(x, satır) = .Cells(i, x)
Next
End If: End If
Next i
ListBox1.Column = list
    End With
   End Sub
 
Sayın Hocam @PLİNT
Dim i As Long
Dim list As Variant, satır As Long, x As Long
ListBox1.Clear bu kısmı göstererek hata mesajı veriyor
 
Dosyanıza göre
"Userform" kod penceresine aşağıdaki kodları ekleyip deneyin
Kod: 
Private Sub TextBox24_Exit(ByVal Cancel As MSForms.ReturnBoolean)
tarihsuz
End Sub
Private Sub TextBox23_Exit(ByVal Cancel As MSForms.ReturnBoolean)
tarihsuz
End Sub
Sub tarihsuz()
Dim i As Long, y As Long, f As Range
Dim list As Variant, satır As Long, x As Long
ListBox1.RowSource = ""
ListBox1.Clear
ListBox1.ColumnCount = 15
Set s1 = Sheets("PASİF_İŞLEMLERİ")
y = s1.Range("a65536").End(3).Row
ReDim list(1 To 15, 1 To 1)
'Label1.Caption = TextBox23.Value
'Label2.Caption = TextBox24.Value
If IsDate(TextBox23) = True And IsDate(TextBox24) = True Then
If CDate(TextBox23) < CDate(TextBox24) Then
ReDim list(1 To 15, 1 To 1)
For i = 2 To s1.Range("a65536").End(3).Row
If IsDate(s1.Cells(i, "G").Text) = True And IsDate(s1.Cells(i, "H").Text) = True Then
If CDate(s1.Cells(i, "G").Text) >= CDate(TextBox23.Text) And CDate(s1.Cells(i, "H").Text) <= CDate(TextBox24.Text) Then
satır = satır + 1
ReDim Preserve list(1 To 15, 1 To satır)
For x = 1 To 15
list(x, satır) = s1.Cells(i, x).Text
Next
End If: End If
Next i
ListBox1.Column = list
GoTo 10
End If: End If
 If IsDate(TextBox23) = True And IsDate(TextBox24) = False Then
For Each f In s1.Range("G2:G" & y)
If IsDate(f.Text) = True Then
If CDate(f.Text) >= CDate(TextBox23.Text) Then
satır = satır + 1
ReDim Preserve list(1 To 15, 1 To satır)
For x = 1 To 15
list(x, satır) = s1.Cells(f.Row, x).Text
Next
End If: End If
Next
ListBox1.Column = list
MsgBox "Gidiş Tarihi" & vbCrLf & TextBox23.Text & vbCrLf & "Tarihi ve Sonra olanlar"
GoTo 10
End If

  If IsDate(TextBox23) = False And IsDate(TextBox24) = True Then
For Each f In s1.Range("H2:H" & y)
If IsDate(f.Text) = True Then
If CDate(f.Text) <= CDate(TextBox24.Text) Then
satır = satır + 1
ReDim Preserve list(1 To 15, 1 To satır)
For x = 1 To 15
list(x, satır) = s1.Cells(f.Row, x).Text
Next
End If: End If
Next
ListBox1.Column = list
MsgBox "Dönüş Tarihi" & vbCrLf & TextBox24.Text & vbCrLf & "Tarihi ve Önce olanlar"
End If
10:
End Sub
 
Hocam çok teşekkür ederim kod çalışıyor. Elinize kolunuza sağlık.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst