• DİKKAT

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

İki Tarih arasını süzerek verileri Başka Sayfaya aktarmak

O

ormann

Katılım
9 Ekim 2009
Mesajlar
1,626
Excel Vers. ve Dili
türkçe
2003
Sayın arkadaşlar ekteki örnekte ana sayfada b6 hücresine başlangıç tarihini,c6 hücresine ise bitiş tarihini yazdığımda duruşmaları aktar dediğimde duruşmalar sayfasında istenilen veriler kayıt sayfasından alınarak duruşmalar sayfasına tarih sırasına göre aktarılabilirmi.?(Kayıtlar kayıt sayfasından silinmeyecek sadece aktarılacak.). ikinci bir tarih seçimi yapıldığında duruşmalar sayfasındaki bir önceki veriler silinip ikinci aktarlanlar gözükecek.Böyle bir şey olabilir mi?
 

Ekli dosyalar

ormann' Alıntı:
Sayın arkadaşlar ekteki örnekte ana sayfada b6 hücresine başlangıç tarihini,c6 hücresine ise bitiş tarihini yazdığımda duruşmaları aktar dediğimde duruşmalar sayfasında istenilen veriler kayıt sayfasından alınarak duruşmalar sayfasına tarih sırasına göre aktarılabilirmi.?(Kayıtlar kayıt sayfasından silinmeyecek sadece aktarılacak.). ikinci bir tarih seçimi yapıldığında duruşmalar sayfasındaki bir önceki veriler silinip ikinci aktarlanlar gözükecek.Böyle bir şey olabilir mi?
Genişletmek için tıkla ...

Bunu denermisiniz.

Sutünlardaki verilerde kayma olabilir kodları kendinize göre uyarlayınız.

Kod: 
Private Sub CommandButton1_Click()

Set sh1 = Sheets("kayıt")
Set sh2 = Sheets("DURUŞMALAR")
Set sh3 = Sheets("ANA SAYFA")
baslangıc = sh3.Cells(6, "b").Value
bitis = sh3.Cells(6, "c").Value
sh2.Range("A2:M65000").ClearContents
deg1 = CDate(baslangıc)
deg2 = CDate(bitis)
sat = 2
If deg1 <= deg2 Then
yer1 = CDate(baslangıc)
yer2 = CDate(bitis)
Else
yer2 = CDate(baslangıc)
yer1 = CDate(bitis)
End If
If IsDate(baslangıc) = True Then
If IsDate(bitis) = True Then
For i = 2 To sh1.Cells(Rows.Count, "a").End(3).Row
If CDate(yer1) <= CDate(sh1.Cells(i, "by").Value) & Chr(10) _
And CDate(yer2) >= CDate(sh1.Cells(i, "by").Value) Then
sh2.Cells(sat, "A").Value = sh1.Cells(i, "BY").Value
sh2.Cells(sat, "B").Value = sh1.Cells(i, "A").Value
sh2.Cells(sat, "C").Value = sh1.Cells(i, "B").Value
sh2.Cells(sat, "D").Value = sh1.Cells(i, "C").Value
sh2.Cells(sat, "E").Value = sh1.Cells(i, "D").Value
sh2.Cells(sat, "F").Value = sh1.Cells(i, "E").Value
sh2.Cells(sat, "G").Value = sh1.Cells(i, "F").Value
sh2.Cells(sat, "H").Value = sh1.Cells(i, "L").Value
sh2.Cells(sat, "I").Value = sh1.Cells(i, "Q").Value
sh2.Cells(sat, "J").Value = sh1.Cells(i, "AP").Value
sh2.Cells(sat, "K").Value = sh1.Cells(i, "AR").Value
sh2.Cells(sat, "L").Value = sh1.Cells(i, "BV").Value
sh2.Cells(sat, "M").Value = sh1.Cells(i, "BX").Value

sat = sat + 1
End If
Next
End If
End If
MsgBox "işlem tamam"
End Sub
 
Sayın Halit hocam çok teşekkür ederim .İstediğim şekilde olmuş. Acaba tarih sırasına göre duruşmalar sayfasına aktarma yapılabilir mi?
 
ormann' Alıntı:
Sayın Halit hocam çok teşekkür ederim .İstediğim şekilde olmuş. Acaba tarih sırasına göre duruşmalar sayfasına aktarma yapılabilir mi?
Genişletmek için tıkla ...

Bunu denermisiniz.

Kod: 
Private Sub CommandButton1_Click()

Set sh1 = Sheets("kayıt")
Set sh2 = Sheets("DURUŞMALAR")
Set sh3 = Sheets("ANA SAYFA")
baslangıc = sh3.Cells(6, "b").Value
bitis = sh3.Cells(6, "c").Value
sh2.Range("A2:M65000").ClearContents
deg1 = CDate(baslangıc)
deg2 = CDate(bitis)
sat = 2
If deg1 <= deg2 Then
yer1 = baslangıc
Else
yer1 = bitis
End If
If IsDate(baslangıc) = True Then
If IsDate(bitis) = True Then
For r = 0 To Val(bitis - baslangıc)
deg = yer1 + r
For i = 2 To sh1.Cells(Rows.Count, "a").End(3).Row
If CDate(deg) = CDate(sh1.Cells(i, "by").Value) Then
sh2.Cells(sat, "A").Value = sh1.Cells(i, "BY").Value
sh2.Cells(sat, "B").Value = sh1.Cells(i, "A").Value
sh2.Cells(sat, "C").Value = sh1.Cells(i, "B").Value
sh2.Cells(sat, "D").Value = sh1.Cells(i, "C").Value
sh2.Cells(sat, "E").Value = sh1.Cells(i, "D").Value
sh2.Cells(sat, "F").Value = sh1.Cells(i, "E").Value
sh2.Cells(sat, "G").Value = sh1.Cells(i, "F").Value
sh2.Cells(sat, "H").Value = sh1.Cells(i, "L").Value
sh2.Cells(sat, "I").Value = sh1.Cells(i, "Q").Value
sh2.Cells(sat, "J").Value = sh1.Cells(i, "AP").Value
sh2.Cells(sat, "K").Value = sh1.Cells(i, "AR").Value
sh2.Cells(sat, "L").Value = sh1.Cells(i, "BV").Value
sh2.Cells(sat, "M").Value = sh1.Cells(i, "BX").Value

sat = sat + 1
End If
Next
Next
End If
End If
MsgBox "işlem tamam"
End Sub
 
Sayın Halit hocam çok teşekkür ederim .ellerinize sağlık .İyi geceler
 
Makroya bazı eklemeler yaptım.

Kod: 
Private Sub CommandButton1_Click()

Set Sh1 = Sheets("kayıt")
Set sh2 = Sheets("DURUŞMALAR")
Set sh3 = Sheets("ANA SAYFA")
baslangıc = sh3.Cells(6, "b").Value
bitis = sh3.Cells(6, "c").Value
If IsDate(baslangıc) = True Then
Else
MsgBox "başlangıç değer tarih olarak gözükmüyor"
Exit Sub
End If
If IsDate(bitis) = True Then
Else
MsgBox "bitiş değer tarih olarak gözükmüyor"
End If
sh2.Range("A2:M65000").ClearContents
deg1 = CDate(baslangıc)
deg2 = CDate(bitis)
sat = 2
If deg1 <= deg2 Then
yer1 = baslangıc
yer2 = bitis - baslangıc
Else
yer1 = bitis
yer2 = baslangıc - bitis
End If

For r = 0 To Val(yer2)
'LookIn:=xlFormulas,LookAt:=xlPart
'LookIn:=xlValues, LookAt:=xlWhole
ad = CDate(yer1 + r)
With Sh1.Range("BY2:BY65000")
Set d = .Find(What:=ad, After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not d Is Nothing Then
FirstAddress = d.Address
Do
sh2.Cells(sat, "A").Value = Sh1.Cells(d.Row, "BY").Value
sh2.Cells(sat, "B").Value = Sh1.Cells(d.Row, "A").Value
sh2.Cells(sat, "C").Value = Sh1.Cells(d.Row, "B").Value
sh2.Cells(sat, "D").Value = Sh1.Cells(d.Row, "C").Value
sh2.Cells(sat, "E").Value = Sh1.Cells(d.Row, "D").Value
sh2.Cells(sat, "F").Value = Sh1.Cells(d.Row, "E").Value
sh2.Cells(sat, "G").Value = Sh1.Cells(d.Row, "F").Value
sh2.Cells(sat, "H").Value = Sh1.Cells(d.Row, "L").Value
sh2.Cells(sat, "I").Value = Sh1.Cells(d.Row, "Q").Value
sh2.Cells(sat, "J").Value = Sh1.Cells(d.Row, "AP").Value
sh2.Cells(sat, "K").Value = Sh1.Cells(d.Row, "AR").Value
sh2.Cells(sat, "L").Value = Sh1.Cells(d.Row, "BV").Value
sh2.Cells(sat, "M").Value = Sh1.Cells(d.Row, "BX").Value
sat = sat + 1
Set d = .FindNext(d)
Loop While Not d Is Nothing And d.Address <> FirstAddress
End If
End With
Set Sh = Nothing
Next
MsgBox "işlem tamam"
End Sub
 

Ekli dosyalar

halit bey muhteşem bir çözüm başka bir alanda kullanmak üzere fikirlerim gelişti sayenizde elinize sağlık
 
Sayın halit3 gibi uzmanlarımız bizlere yol gösteren rehberlerimiz olan gönül dostlarımız. İyi ki varsınız... Sağ olun var olun...

Katkılarınız için teşekkürler.

Sevgi ve saygılar.
 
assenucler' Alıntı:
Sayın halit3 gibi uzmanlarımız bizlere yol gösteren rehberlerimiz olan gönül dostlarımız. İyi ki varsınız... Sağ olun var olun...

Katkılarınız için teşekkürler.

Sevgi ve saygılar.
Genişletmek için tıkla ...

Teşekkürler Allah razı olsun iyi çalışmalar diliyorum.
 
ödeme listesi

Halit3 hocamızın örneğinden yola çıkarak hazırlamış olduğum bir çalışma, sayfalar korumalı fakat şifresizdir,

sayfalar arası geçişleri butonlarla yapın tarih seçimlerini yanlarındaki seçim kutucukları ile yapabilirsiniz.

Tarih gir fonksiyonu için vb6 gerekebilir...

Umarım işinize yarar.
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst