Makro Yardım

[__TR__]

Aşağıda bulunan makro ile; UserForm üzerindeki Textbox'a girdiğim tarihi Sayfa1'in D3: D30 aralığında aratıp eşleşen tarihlere ait A3:A30 sütunundaki sadece dolu olan satırları, Sayfa2'nin A1 hücresinden itibaren alt alta boşluk olmadan yazmasına uğraşıyorum ancak bir türlü çözemedim.
Makro kısmen oluştu gibi ama bu haliyle bütün bilgileri getiriyor, ben sadece girilen tarihe ait şimdilik A3:A30 aralığındaki dolu hücrelerin gelmesini istiyorum. Rica etsem nerde hata yapıyorum atladığım kısım neresi yardımcı olursanız sevinirim.
Gelmesi gereken başka sütunlarda var c,e,f vs gibi mantığını kavrarsam kendimde yapabilirim düşüncesiyle şimdilik sadece A3:A30 arasını aktarsam yeter.

Private Sub CommandButton1_Click()
Dim s1 As Worksheet, s2 As Worksheet
Dim bul As Range, satır As Long
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Application.ScreenUpdating = False
For Each bul In s1.Range("D3:D30")
If bul.Value = TextBox1.Text Then
satır = satır + 1
s1.Range("A3:A30").SpecialCells(xlCellTypeConstants, 23).Copy Range("A1")
End If
Next bul
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[PLİNT]

Merhaba
Aşağıdaki gibi olabilir

[SIZE="2"]Private Sub CommandButton1_Click()
Dim s1 As Worksheet, s2 As Worksheet
Dim bul As Range, satır As Long
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Application.ScreenUpdating = False
s1.Range("$A$1:$F$30").AutoFilter Field:=4, Criteria1:=TextBox1
satır = s2.Cells(Rows.Count, "A").End(3).Row +1
s1.Range("A2:F30").SpecialCells(xlCellTypeConstants, 23).Copy s2.Range("A" & satır)
s1.Range("$A$1:$F$30").AutoFilter
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub[/SIZE]

 

[__TR__]

Maalesef çalışmadı sayın Plint, yine bütün bilgilerin hepsini getiriyor. Ayrıca A sütununda herhangi bir boş hücre olması durumunda;
s1.Range("A2:F30").SpecialCells(xlCellTypeConstants, 23).Copy s2.Range("A" & satır)
satırı hata veriyor.

 

[Korhan Ayhan]

Alternatif,

Private Sub CommandButton1_Click()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Veri As Range, Satır As Long
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    Application.ScreenUpdating = False
    
    For Each Veri In S1.Range("D3:D30")
        If Veri.Value = CDate(TextBox1.Text) Then
            If S1.Cells(Veri.Row, "A") <> "" Then
                Satır = Satır + 1
                S2.Cells(Satır, "A") = S1.Cells(Veri.Row, "A")
            End If
        End If
    Next
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True

    MsgBox CDate(TextBox1.Text) & " tarihine ait veriler aktarılmıştır.", vbInformation
End Sub

 

[__TR__]

Sayın Korhan Ayhan hocam çok teşekkür ederim günlerdir uğraştığım çok büyük bir dertten kurtardınız beni.

 

[__TR__]

Sayın Korhan Ayhan hocam vermiş olduğunuz kod sorunsuz bir şekilde çalışıyor tekrardan çok teşekkür ederim.

Hocam aynı makro içerisine bir kaç ekleme yaptım, yine aranan tarihle S2'ye S3'tende veri çektim. Sadece S3'ün B sütunundan gelecek verileri S2'nin J2:J11 aralığında nasıl listelerim? Aşağıdaki kodu nasıl düzenlemem gerek.

For Each Veri In S3.Range("A2:A50")
If Veri.Value = CDate(TextBox1.Text) Then
If S3.Cells(Veri.Row, "B") <> "" Then
Satır = Satır + 1
S2.Cells(Satır, "J") = S3.Cells(Veri.Row, "B")