Çözüldü İki tarih arası verilerin filtrelenerek diğer sahifeye aktarımı hk.

[kemal turan]

Merhaba,
İki tarih arası verilerin filtrelenerek rapor sahifesine aktarımı için aşağıdaki kodu sitemizden bularak kendime ayarladım.
Bir sıkıntım var.
ilk ve son tarihten herhangi biri yok ise "MsgBox "Başlangıç ve bitiş tarihlerini kontrol ediniz!", , "" Mesajı veriyor.
isteğim herhangi biri yok ise de belirtilen tarihler arasındaki verilerin gelmesi.
teşekkür ederim.

Sub Dikdörtgen2_Tıkla()
If Range("c4").Value = 0 Then
MsgBox "Belirtilen günlere ait veri yok."
Exit Sub
End If
Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Dim son1 As Long, son3 As Long
Set s1 = Sayfa15: Set s2 = Sayfa16: Set s3 = Sayfa26
''''''S1= KAYITLARIN OLDUĞU''''''''S2=TARİH OLAN''''''''S3=AKTARILAN

son1 = s1.Cells(Rows.Count, 73).End(3).Row
son3 = s3.Cells(Rows.Count, 1).End(3).Row + 1
s3.Range("A2:S" & son3).Clear

baslangic = s2.Range("D2")
bitis = s2.Range("D3")

Set bul1 = s1.Range("BU2:BU" & son1).Find(baslangic)
Set bul2 = s1.Range("BU2:BU" & son1).Find(bitis)

If Not bul1 Is Nothing And Not bul2 Is Nothing Then
ilk_satir = bul1.Row: son_satir = bul2.Row

s1.Range("BU" & ilk_satir & ":CD" & son_satir).Copy s3.Range("A2")
s3.Columns("A:S").AutoFit
Sheets("rapor2").Select
Else
MsgBox "Başlangıç ve bitiş tarihlerini kontrol ediniz!", , ""
End If
 
End Sub

 

[zpawnz]

Sub Dikdörtgen2_Tıkla() 
   If Range("c4").Value = 0 Then 
      MsgBox "Belirtilen günlere ait veri yok." 
      Exit Sub 
   End If 
    
   Dim s1 As Worksheet, s2 As Worksheet, s3 As Worksheet 
   Dim son1 As Long, son3 As Long 
   Set s1 = Sayfa15: Set s2 = Sayfa16: Set s3 = Sayfa26 
    
   son1 = s1.Cells(Rows.Count, 73).End(3).Row 
   son3 = s3.Cells(Rows.Count, 1).End(3).Row + 1 
   s3.Range("A2:S" & son3).Clear 
    
   baslangic = s2.Range("D2") 
   bitis = s2.Range("D3") 
    
   Set bul1 = s1.Range("BU2:BU" & son1).Find(baslangic) 
   Set bul2 = s1.Range("BU2:BU" & son1).Find(bitis) 
    
   If Not bul1 Is Nothing And Not bul2 Is Nothing Then 
      ilk_satir = bul1.Row 
      son_satir = bul2.Row 
      s1.Range("BU" & ilk_satir & ":CD" & son_satir).Copy 
      s3.Range("A2").Paste 
      s3.Columns("A:S").AutoFit 
      Sheets("rapor2").Select 
   Else 
      'ist the data between the start and end dates 
      Dim startDate As Date, endDate As Date 
      startDate = s2.Range("D2").Value 
      endDate = s2.Range("D3").Value 
      
      Dim dataRange As Range 
      Set dataRange = s1.Range("BU2:BU" & son1) 
      
      Dim cell As Range 
      For Each cell In dataRange 
        If cell.Value >= startDate And cell.Value <= endDate Then 
           s3.Range("A" & s3.Rows.Count).End(3)(2).Value = cell.Value 
        End If 
      Next cell 
   End If 
End Sub

Dener misiniz?

 

[kemal turan]

Çok teşekkür ederim. Yarın uygulayarak geri dönüş yaparım

 

[kemal turan]

Merhaba
Yukarıdaki kodunuzu akşam deneme fırsatım oldu.
kodumuz sadece a sutunundaki tarih verilerini aktarma yapıyordu.
Ben biraz daha sitemizi araştırdım. 2013 yılında Necdet hocamızın bir cevabını kendi sayfalarıma uyarlayarak aşağıdaki kod sonuca ulaştım.
İlgi ve emeğinize teşekkür ederim.

Sub Dikdörtgen2_Tıkla()
Dim i   As Long, _
j   As Long, _
Adt As Integer, _
ShG As Worksheet, _
ShD As Worksheet, _
ShR As Worksheet

Set ShG = Sheets("SEL3VERI")
Set ShD = Sheets("RAPOR2")
Set ShR = Sheets("RAPOR")

j = ShD.Cells(Rows.Count, "A").End(3).Row

ShD.Range("A2:S" & j).ClearContents
j = 1

For i = 2 To ShG.Cells(Rows.Count, "BU").End(3).Row
If (ShG.Cells(i, "BU") >= ShR.Range("D2") And ShG.Cells(i, "BU") <= ShR.Range("D3")) Then
j = j + 1
Adt = Adt + 1
ShG.Range("BU" & i & ":CM" & i).Copy ShD.Range("A" & j)
End If
Next i

If Adt = 0 Then
MsgBox "AKTARILACAK ŞARTA UYGUN VERİ BULUNMADI....", vbCritical
Else
MsgBox Adt & " Adet Veri Aktarılmıştır....", vbInformation
End If
Sheets("rapor2").Select
End Sub

 

[zpawnz]

Rica ederim.