2 tarih arasında kalan tarihleri sıralatmak

[CenTay]

Selamlar ve iyi geceler herkese, sayfadaki b4 b500 arasındaki tarihleri bir başka sayfadaki d1 ve f1 deki tarihe göre ,b5 ten itibaren sıralatmak istiyorum. makro butonsuz olursa iyi olur.f1 e tarih girince sıralama gerçekleşsin istiyorm.

http://s2.dosya.tc/server2/je22vi/2_tarih_arasi_gunleri_siralamak.CenTay.xls.html

 

[Ömer BARAN]

Merhaba.

Alt taraftan ARA sayfasının adına fareyle sağ tıklayın ve KOD GÖRÜNTÜLEyi seçin.
Açılan ekranın sağ tarafındaki boş alana aşağıdaki kod'u yapıştırın.
ARA sayfasındaki tarihlerde (D1, F1) değişiklikler yaparak sonucu gözlemleyin.
ARA sayfasında B sütununu seçip biçimi tarih olarak ayarlayın.
.

[FONT="Arial Narrow"]Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D1,F1]) Is Nothing Then Exit Sub
If Target = "" Or [D1] > [F1] Then
MsgBox "D1 hücresindeki tarih F1 hücresindeki tarihten büyük olamaz." & vbLf & _
        "D1 ve F1 hücreleri boş bırakılamaz."
Exit Sub
End If
    Call listele
End Sub
Sub listele()
Set s1 = Sheets("TARİH"): Set s2 = Sheets("ARA")
If s2.[B65536].End(3).Row <> 1 Then s2.Range("B4:B65536").ClearContents
For satır = 4 To 500
    If s2.[D1].Value <= s1.Cells(satır, 2).Value And s2.[F1].Value >= s1.Cells(satır, 2).Value Then _
    s2.Cells(WorksheetFunction.Max(s2.[B65536].End(3).Row + 1, 5), 2) = s1.Cells(satır, 2)
Next
End Sub[/FONT]

 

[vardar07]

Ara sayfası kod bölümüne ekleyip deneyiniz. Sadece F! e değer girince çalışır.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("F1")) Is Nothing Then Exit Sub
Set s1 = Sheets("TARİH")
With Sheets("ARA")
.Range("B5:B500").ClearContents
x = 5
For i = 4 To 500
If s1.Cells(i, "B") >= .Cells(1, "D") And s1.Cells(i, "B") <= .Cells(1, "F") Then
.Cells(x, "B") = s1.Cells(i, "B")
x = x + 1
End If
Next
End With
End Sub

Ömer bey cevap vermiş alternatif olsun.

 

[CenTay]

Merhaba.

Alt taraftan ARA sayfasının adına fareyle sağ tıklayın ve KOD GÖRÜNTÜLEyi seçin.
Açılan ekranın sağ tarafındaki boş alana aşağıdaki kod'u yapıştırın.
ARA sayfasındaki tarihlerde (D1, F1) değişiklikler yaparak sonucu gözlemleyin.
ARA sayfasında B sütununu seçip biçimi tarih olarak ayarlayın.
.

[FONT="Arial Narrow"]Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D1,F1]) Is Nothing Then Exit Sub
If Target = "" Or [D1] > [F1] Then
MsgBox "D1 hücresindeki tarih F1 hücresindeki tarihten büyük olamaz." & vbLf & _
        "D1 ve F1 hücreleri boş bırakılamaz."
Exit Sub
End If
    Call listele
End Sub
Sub listele()
Set s1 = Sheets("TARİH"): Set s2 = Sheets("ARA")
If s2.[B65536].End(3).Row <> 1 Then s2.Range("B4:B65536").ClearContents
For satır = 4 To 500
    If s2.[D1].Value <= s1.Cells(satır, 2).Value And s2.[F1].Value >= s1.Cells(satır, 2).Value Then _
    s2.Cells(WorksheetFunction.Max(s2.[B65536].End(3).Row + 1, 5), 2) = s1.Cells(satır, 2)
Next
End Sub[/FONT]

Ömer hocam yine imdada yetiştin Sağol ellerine sağlık.Çok çok teşekkür ederim hayırlı sabahlar.

 

[CenTay]

Ara sayfası kod bölümüne ekleyip deneyiniz. Sadece F! e değer girince çalışır.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("F1")) Is Nothing Then Exit Sub
Set s1 = Sheets("TARİH")
With Sheets("ARA")
.Range("B5:B500").ClearContents
x = 5
For i = 4 To 500
If s1.Cells(i, "B") >= .Cells(1, "D") And s1.Cells(i, "B") <= .Cells(1, "F") Then
.Cells(x, "B") = s1.Cells(i, "B")
x = x + 1
End If
Next
End With
End Sub

Ömer bey cevap vermiş alternatif olsun.

Vardar 07 hocam size de teşekkür ederim sağolun ben de böylece biraz biraz kod öğreniyorum hayırlı sabahlar

 

[Ömer BARAN]

Ömer hocam yine imdada yetiştin Sağol ellerine sağlık.Çok çok teşekkür ederim hayırlı sabahlar.

Eyvallah, iyi günler dilerim.

 

[Orion1]

Alternatif.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim sh As Worksheet
If Intersect(Target, [F1]) Is Nothing Then Exit Sub
Set sh = Sheets("TARİH")
Range("B5:B502").ClearContents
sh.Range("B3").AutoFilter
sh.Range("B3").AutoFilter field:=1, Criteria1:=">=" & CLng(CDate(Range("D1").Value)), _
        Operator:=xlAnd, Criteria2:="<=" & CLng(CDate(Target.Value))
sh.Range("B3").CurrentRegion.Copy Range("B5")
sh.Range("B3").AutoFilter
End Sub

 

[CenTay]

Alternatif.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim sh As Worksheet
If Intersect(Target, [F1]) Is Nothing Then Exit Sub
Set sh = Sheets("TARİH")
Range("B5:B502").ClearContents
sh.Range("B3").AutoFilter
sh.Range("B3").AutoFilter field:=1, Criteria1:=">=" & CLng(CDate(Range("D1").Value)), _
        Operator:=xlAnd, Criteria2:="<=" & CLng(CDate(Target.Value))
sh.Range("B3").CurrentRegion.Copy Range("B5")
sh.Range("B3").AutoFilter
End Sub

Selamlar Orion1 hocam geç gördüm özür dilerim elinize sağlık ve teşekkür ediyorum Bayramınız kutlu olsun.