TARİH SORGUSU

[agunes4242]

VERİDEKİ BİLGİLERİ İKİ TARİH KOŞULUNA GÖRE LİSTE SAYFASINA YAZDIRMA

 

[Necdet]

Merhaba,
ilk ve son tarihleri doldurmak zorunda değilsiniz.
İlk tarih boş ise min tarihten itibaren ikinci tarihe kadar olanları,
ikinci tarih boş ise sonuna kadar listeler.

Ayrıca Liste sayfasında A sütununa başlıkları yazmanıza gerek yok, kod hallediyor.
Kod içinde Sayfa1 olarak kodlanan Sheets("VERİ"), Sayfa2 olarak ta Sheets("LİSTE") anlamında kullanılmıştır. Yani sayfa adını değil sayfa indisini kullandım.
Parametrik olsun istedim.

Sub Listele()

Dim arr As Variant
Dim diz(1 To 5, 1 To 2) As Variant
Dim i   As Long
Dim j   As Long
Dim adt As Integer
Dim tar1 As Date
Dim tar2 As Date

Application.ScreenUpdating = False

Sayfa2.Range("A:B").ClearContents
diz(1, 1) = "ADI SOYADI"
diz(2, 1) = "TELEFONU"
diz(3, 1) = "ADRESİ"
diz(4, 1) = "BİLGİ"
diz(5, 1) = "TARİH"

tar1 = Sayfa2.Range("F2")
If tar1 = "00:00:00" Then tar1 = Application.WorksheetFunction.Min(Sayfa1.Range("F:F"))
tar2 = Sayfa2.Range("F3")
If tar2 = "00:00:00" Then tar2 = Application.WorksheetFunction.Max(Sayfa1.Range("F:F"))

j = 2

arr = Sayfa1.Range("A1").CurrentRegion.Value

For i = 2 To UBound(arr, 1)
    If arr(i, 6) >= tar1 And arr(i, 6) <= tar2 Then
        diz(1, 2) = arr(i, 2)
        diz(2, 2) = arr(i, 3)
        diz(3, 2) = arr(i, 4)
        diz(4, 2) = arr(i, 5)
        diz(5, 2) = arr(i, 6)
        Sayfa2.Cells(j, "A").Resize(5, 2) = diz
        adt = adt + 1
        j = j + 7
    End If
Next i

Application.ScreenUpdating = True
MsgBox adt & " ADET KAYIT AKTARILMIŞTIR ...."

End Sub

 

[Korhan Ayhan]

Ek olarak;

Rica etsem profilinizde yazan "Excel Vers. ve Dili Excel" bilgisini aşağıdaki linki inceleyerek güncelleyebilirmisiniz.

Bilgi - Profillerde yazan "Ofis Sürümü ve Dili" bilgisi hakkında

Merhaba Değerli Forum Üyeleri, Belki dikkatinizi çekmiştir. Son zamanlarda birçok üyemize açtıkları başlıklarda cevap vermeden önce "Kullandığınız ofis sürümü ve dili nedir?" şeklinde mesaj yazıyorum. Bu alanın kullanım amacı sizlere verilecek cevaplar için önem arz etmektedir. Bu sebeple bu...

www.excel.web.tr

 

[Necdet]

Merhaba,
Buraya eklenen dosya ile asıl dosya arasındaki uyumsuzluk nedeniyle, düzenleyemediğiniz kod :
Dosyanızda 2 adet tarih var, eğer tarih olarak C sütunundaki kullanılacaksa ve karşılaştırma buna göre yapılacaksa
kodda geçen arr(i,20) yerine arr(i,3) olarak kullanınız.

Sub Listele()

Dim arr As Variant
Dim diz(1 To 5, 1 To 2) As Variant
Dim i   As Long
Dim j   As Long
Dim adt As Integer
Dim tar1 As Date
Dim tar2 As Date

Application.ScreenUpdating = False

Sayfa2.Range("A:B").ClearContents
diz(1, 1) = "KİME AİT OLDUĞU"
diz(2, 1) = "GELDİĞİ YER"
diz(3, 1) = "KONUSU"
diz(4, 1) = "SONTARİH"
diz(5, 1) = "SAAT"

tar1 = Sayfa3.Range("E2")
If tar1 = "00:00:00" Then tar1 = Application.WorksheetFunction.Min(Sayfa1.Range("T:T"))
tar2 = Sayfa3.Range("E3")
If tar2 = "00:00:00" Then tar2 = Application.WorksheetFunction.Max(Sayfa1.Range("T:T"))

j = 2

arr = Sayfa1.Range("A1").CurrentRegion.Value

For i = 2 To UBound(arr, 1)
    If arr(i, 20) >= tar1 And arr(i, 20) <= tar2 Then
        diz(1, 2) = arr(i, 14)  'Kime Ait Olduğu Sütun
        diz(2, 2) = arr(i, 5)   'Geldiği Yer
        diz(3, 2) = arr(i, 6)   'Konusu
        diz(4, 2) = arr(i, 20)  'Son Tarih
        diz(5, 2) = arr(i, 21)  'Saat
        Sayfa3.Cells(j, "A").Resize(5, 2) = diz
        adt = adt + 1
        j = j + 7
    End If
Next i

Application.ScreenUpdating = True
MsgBox adt & " ADET KAYIT AKTARILMIŞTIR ...."

End Sub