İki tarih arası veri aktarma

[ASLAN7410]

Merhaba hayırlı geceler.

Ekte gönderdiğim excel sayfamın 1.sayfasına sistemden aldığım verileri yapıştırıyorum, bu veriler içerisinden belirli tarihteki verileri butonla sayfa2'ye yapıştırmak istiyorum.

Makro kaydet ile Ctrl+F'yi kullanarak yapıyorum, veriler sabit olmadığı için olmuyor.

Yardım edecek arkadaşlara şimdiden teşekkür ederim.

 

[Ömer BARAN]

Merhaba.

Aşağıdeki gibi olabilir.
Sayfa1'de O1 hücresine başlangıç, P1 hücresine de bitiş tarihini yazın ve düğmeye tıklayın.
.

[FONT="Arial Narrow"]Sub TARİH_AKTAR()
Set s1 = Sheets("Sayfa1"): Set s2 = Sheets("Sayfa2")
s1.Range("A1:M" & Rows.Count).AutoFilter Field:=5, Criteria1:= _
    ">=" & CLng(s1.[[B][COLOR="blue"]O1[/COLOR][/B]]), Operator:=xlAnd, Criteria2:="<=" & CLng(s1.[[B][COLOR="Red"]P1[/COLOR][/B]])
s2.Range("A1:M" & s2.Cells(Rows.Count, "E").End(3).Row).ClearContents
s2.Range("A1:M" & s2.Cells(Rows.Count, "E").End(3).Row).Borders.LineStyle = xlNone
If Evaluate("=SUBTOTAL(3,Sayfa1!E:E)") > 1 Then
s1.Range("A1:M" & Rows.Count).CurrentRegion.Copy s2.[A1]
s1.Range("A1:M" & Rows.Count).AutoFilter Field:=5
s2.Range("A1:M" & s2.Cells(Rows.Count, "E").End(3).Row).Borders.LineStyle = xlContinuous
With s2.Range("A2:A" & s2.[E65536].End(3).Row): .Formula = "=ROW()-1": .Value = .Value: End With
Else: s1.Range("A1:M" & Rows.Count).AutoFilter Field:=5: End If: s2.Activate
End Sub[/FONT]

 

[ASLAN7410]

Sayın Ömer Bey ilginize çok teşekkür ederim, kodlar gayet güzel çalışıyor.

Sonradan fark ettim kusura bakmayın, kendi orijinal verimi kontrol ettiğimde tarihin yanında saat dakika saniye var, ondan dolayıda aktarma yapmıyor.

1.Mesajda örneği tekrar yükledim.

 

[vardar07]

Deneyiniz.

 

[ASLAN7410]

Sayın vardar07 ilginize çok teşekkür ederim.

3.Numaralı mesajımda yazmıştım.

Kendi verilerim de sonradan fark ettim tarihin yanında saat dakika saniye var.

Bu şekilde değerlendirir misiniz?

 

[Ziynettin]

Merhaba,
E1 başlama tarihi,
E2 bitiş tarihi girildiğinde kodu çalıştırın.

Option Explicit
Sub aktar()
Dim a(), b(), S1 As Worksheet, i As Long, Say As Long
Dim Tarih_1 As Date, Tarih_2 As Date, y As Byte

Set S1 = Worksheets("Sayfa1")
a = S1.Range("A4:M" & S1.Cells(Rows.Count, 1).End(3).Row).Value
Tarih_1 = S1.[E1]
Tarih_2 = S1.[E2]

ReDim b(1 To UBound(a), 1 To UBound(a, 2))
For i = 1 To UBound(a)
    If a(i, 5) >= Tarih_1 And a(i, 5) <= Tarih_2 Then
        Say = Say + 1
        b(Say, 1) = Say
        For y = 2 To UBound(a, 2)
            b(Say, y) = a(i, y)
        Next y
    End If
Next i

With Sheets("sayfa2")
.Range("A2:M" & Rows.Count).ClearContents
If Say > 0 Then
.[A2].Resize(Say, UBound(a, 2)) = b
End If
.Select
End With
MsgBox "İşleminiz tamamlandı.", vbInformation
End Sub

 

[ASLAN7410]

Sayın Ziynettin Bey çok teşekkür ederim tam istediğim gibi oldu, Allah razı olsun.

Hayırlı geceler hayırlı çalışmalar.