İki tarih arası

[veyselk]

Arkadaşlar ekte gönderdiğim dosya için yardımcı olursanız sevinirim. Şimdiden teşekkürler.

 

[N.Ziya Hiçdurmaz]

yanıt

Sub test()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Range("a2:b5000").Clear
For sut = 4 To [a65536].End(xlUp).Row
If s1.Range("a" & sut) >= [a2] And s1.Range("a" & sut) <= [a3] Then
s1.Range("a" & sut & ":b" & sut).Copy
s = s2.[a65536].End(xlUp).Row + 1
s2.Range("a" & s).PasteSpecial
End If
Next
Application.DataEntryMode = False
End Sub

 

[veyselk]

İki Tarih Arası

İstediğim tam bu değil. Aktarım tamam ancak b sütununda bulunan iki tarih arası bilgilerin yazılı olduğu hücreler kopyalansın.

 

[Ferhat Pazarçevirdi]

Aşağıdaki kodu standart bir modül sayfasına kopyalayarak çalıştırınız.

Sub Aktar()
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim i%, son%
Set Sh1 = Sheets("Sayfa1")
Set Sh2 = Sheets("Sayfa2")
Sh2.Range("A2:B100").ClearContents
For i = 4 To 100
    If Sh1.Cells(i, 1) >= Sh1.Cells(2, 1) And Sh1.Cells(i, 1) <= Sh1.Cells(3, 1) Then
       son = Sh2.Cells(65536, 1).End(xlUp).Row
       Sh2.Cells(son + 1, 1) = Sh1.Cells(i, 1)
       Sh2.Cells(son + 1, 2) = Sh1.Cells(i, 2)
    End If
Next i
Set Sh1 = Nothing
Set Sh2 = Nothing
End Sub

 

[veyselk]

iki tarih arası

sayın fpc sizin gönderdiğiniz kod da aynı aktarma oluyor. Ekli dosyada değişiklik yaptım sayfa1 den sayfa 2 ye aktarım yapıldıktan sonra sayfa 2 deki gibi olsun istiyorum . İlgileriniz için teşekkürler.

 

[Ferhat Pazarçevirdi]

Sadece bilgi içeren hücreleri aktarmak istiyorum deseniz, daha kısa sürecekti

Aşağıdaki kodu deneyin.

Sub Aktar()
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim i%, son%
Set Sh1 = Sheets("Sayfa1")
Set Sh2 = Sheets("Sayfa2")
Sh2.Range("A2:B100").ClearContents
For i = 4 To 100
    If Sh1.Cells(i, 1) >= Sh1.Cells(2, 1) And Sh1.Cells(i, 1) <= Sh1.Cells(3, 1) Then
       If Trim(Sh1.Cells(i, 2)) <> Empty Then
          son = Sh2.Cells(65536, 1).End(xlUp).Row
          Sh2.Cells(son + 1, 1) = Sh1.Cells(i, 1)
          Sh2.Cells(son + 1, 2) = Sh1.Cells(i, 2)
       End If
    End If
Next i
Set Sh1 = Nothing
Set Sh2 = Nothing
End Sub

 

[veyselk]

Sayın fpc teşekkür ederim istediğim oldu.

 

[Orion1]

Bende hazırlamıştım.
Yabana boşa gitmesin bari.Ekli dosyayı inceleyiniz.

Sub rapor()
Dim ilk_tarih, son_tarih, tarih As Date, sat, i As Long
Sheets("Sayfa1").Select
Sheets("Sayfa2").Range("A2:B65536").ClearContents
sat = 2
Application.ScreenUpdating = False
ilk_tarih = CDate(Range("A2").Value)
son_tarih = CDate(Range("A3").Value)
For i = 4 To Cells(65536, "A").End(xlUp).Row
    tarih = CDate(Cells(i, "A").Value)
    If tarih >= ilk_tarih And tarih <= son_tarih Then
        Sheets("Sayfa2").Cells(sat, "A").Value = CDate(tarih)
        Sheets("Sayfa2").Cells(sat, "B").Value = Cells(i, "B").Value
        sat = sat + 1
    End If
Next
Application.ScreenUpdating = True
MsgBox "İki tarih arası rapor çıkarıldı.!", vbOKOnly + vbInformation
End Sub