İstenilen tarih aramasi sonucu

[ppeacee]

Merhabalr arkadaslar, excelde belirli bir tarih aramasini yaptirabiliyorum verilerimden. Ama sunu yaparken zorlandim. W hucresinin altinda tarihler var ve genel olarak w2 01.07.2017 w3 01.07.2017 w4 01.07.2017 w5 02.07.2017 w6 02.07.2017 w7 02.07.2017 seklinde sirali genelde. Benim istedigim girilen tarih sonucuna gore satirin yanindaki verileride kopyalayip a3 yapistirmak.Şimdiden teşekkür ederim

 

[Korhan Ayhan]

Merhaba,

Örnek dosya ekleyerek yapmak istediğiniz işlemi açıklayabilir misiniz?

Paylaşım sitelerine örnek dosyanızı yükleyip link verebilirsiniz.

 

[ppeacee]

Tarih arandığı zaman w sütunundaki taranip aranan tarihteki ve vardiya durumuna gore yandaki verilerle beraber a sütunundaki bolgeye yapistirilmasini istiyorum. Tarih girilmezse hata verip dogru tarih girilmesini istiyorum korhan bey
dosya buradan indirebilirsiniz

 

[Korhan Ayhan]

Deneyiniz.

Sub Tarih_Bul()
    Dim Ara As Variant, Bul As Range, Adres As String
    
    Ara = Application.InputBox("Aranacak tarihi giriniz..." & Chr(10) & Chr(10) & "gg.aa.yyyy")
    If Ara = "" Or Not IsDate(Ara) Then
        MsgBox "Lütfen tarih giriniz...", vbCritical
        Exit Sub
    End If
    
    Range("B8:B10,D8:F10").ClearContents
    
    Set Bul = Range("W:W").Find(What:=CDate(Ara))
    If Not Bul Is Nothing Then
        Adres = Bul.Address
        Do
            Select Case Bul.Offset(0, 1)
                Case "24 / 08"
                    Cells(8, "B") = Bul.Offset(0, 2)
                    Cells(8, "D") = Bul.Offset(0, 4)
                    Cells(8, "E") = Bul.Offset(0, 5)
                    Cells(8, "F") = Bul.Offset(0, 6)
                Case "08 / 16"
                    Cells(9, "B") = Bul.Offset(0, 2)
                    Cells(9, "D") = Bul.Offset(0, 4)
                    Cells(9, "E") = Bul.Offset(0, 5)
                    Cells(9, "F") = Bul.Offset(0, 6)
                Case "16 / 24"
                    Cells(10, "B") = Bul.Offset(0, 2)
                    Cells(10, "D") = Bul.Offset(0, 4)
                    Cells(10, "E") = Bul.Offset(0, 5)
                    Cells(10, "F") = Bul.Offset(0, 6)
            End Select
            Set Bul = Range("W:W").FindNext(Bul)
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
    End If
End Sub