Makro find komutu ile hücre eşleme

[hmtstc]

Merhaba arkadaşlar,

Sizlerin sayesinde bir ilerleme kaydettim.
Ancak sizden yardım rica ediyorum.
Elimde 2 sayfa var.
Sayfa1 ve sayfa2

Sayfa2 de belirli değerler var. en üstte B2 de tarih ve vardiyası yazılı
18.07.2016 22:30 - 06:30 şeklinde.

Sayfa1 de ise
1. satırda

01.07.2016 22:30 - 06:30 01.07.2016 06:30 - 14:30 01.07.2016 14:30 - 22:30 02.07.2016 22:30 - 06:30 02.07.2016 06:30 - 14:30 02.07.2016 14:30 - 22:30....

şeklinde sıralanmış şekilde tarih ve vardiyalar yazılı.

Bende istiyorum ki bir butona bir makro yazayım ve şu işlemi yapsın,

Sayfa2deki tarih ve saat hücresini, sayfa1 de 1. satırdaki veriler arasından bul,
daha sonra bulduğun hücrenin 6. satırından itibaren sayfa2 deki verileri kopyala ve yapıştır.

Temel mantığım bu.
Bir çok kısmını halledebileceğim bir şekilde ama baştaki koşulu kuramıyorum. Satırda o hücreyi bulup hangi sütunda olduğunu sonraki formüllerde belirtmem gerekiyor.

Örnek bir dosya ekliyorum.
Sarı renkli hücreler aktarmak istediklerim.
Yardımınız için teşekkür ederim.

http://s6.dosya.tc/server7/fsjxw8/ornek.xlsx.html

 

[YUSUF44]

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz. Kodun düzgün çalışması için aranan vardiyanın vardiya listesine yazıldığı şekilde birebir aynı girilmesi gerekmektedir. Örnek dosyanızda B2 hücresinde 2.7.2016 06:30 - 14:30 şeklinde, vardiya listesinde ise 02.07.2016 06:30 - 14:30 şeklinde yazdığı için makro çalışmayacak ve hata verecektir.

Sub aktar()
Set s2 = Sheets("RAPOR")
Set rapor = s2.Range("C10:D19")

vardiya = s2.[B2].Value
son = Cells(1, Columns.Count).End(xlToLeft).Column

Set vardiyalar = Range(Cells(1, "B"), Cells(1, son))

If WorksheetFunction.CountIf(vardiyalar, vardiya) = 0 Then
    MsgBox "Arama yapılan vardiya vardiya listesinde bulunmamaktadır. " _
            & Chr(10) & "Lütfen tamamen aynı şekilde yazdığınızdan emin olunuz!", vbCritical
    s2.Select
    [B2].Select
    GoTo 10
End If
For i = 2 To son Step 2
    If Cells(1, i) = vardiya Then
        rapor.Copy Cells(6, i)
    End If
Next
10:
End Sub

Makroyu RAPOR sayfasındayken değil verilerinizin olduğu TEMMUZ gibi sayfalarda çalıştırmalısınız. RAPOR sayfasında çalıştırırsanız hatalı işlem yapar.

 

[YUSUF44]

Sadece değerleri aktarmak için

rapor.Copy Cells(6, i)

Satırı yerine aşağıdaki kodları deneyin:

Cells(i, 6) = s2.[C10]
Cells(i+1,6) = s2.[D10]
Cells(i, 7) = s2.[C11]
Cells(i+1,7) = s2.[D11]

Bu şekilde tüm değerler için kodu çoğaltın. 8'e 12, 9'a 13 şeklinde.

 

[YUSUF44]

Az önce satırla sütunu karıştırmışım, aşağıdaki gibi olmalı:

Cells(6, i) = s2.[C10]
Cells(6, i+1) = s2.[D10]
Cells(7, i) = s2.[C11]
Cells(7, i+1) = s2.[D11]

Bu şekilde tüm değerler için kodu çoğaltın. 8'e 12, 9'a 13 şeklinde.

 

[YUSUF44]

Son hali şöyle oldu:

Sub aktar()
Set s2 = Sheets("RAPOR")
Set rapor = s2.Range("C10:D19")

vardiya = s2.[B2].Value
son = Cells(1, Columns.Count).End(xlToLeft).Column

Set vardiyalar = Range(Cells(1, "B"), Cells(1, son))

If WorksheetFunction.CountIf(vardiyalar, vardiya) = 0 Then
    MsgBox "Arama yapılan vardiya vardiya listesinde bulunmamaktadır. " _
            & Chr(10) & "Lütfen tamamen aynı şekilde yazdığınızdan emin olunuz!", vbCritical
    s2.Select
    [B2].Select
    GoTo 10
End If
For i = 2 To son Step 2
    If Cells(1, i) = vardiya Then
        Cells(6, i) = s2.[C10]
        Cells(6, i + 1) = s2.[D10]
        Cells(7, i) = s2.[C11]
        Cells(7, i + 1) = s2.[D11]
        Cells(8, i) = s2.[C12]
        Cells(8, i + 1) = s2.[D12]
        Cells(9, i) = s2.[C13]
        Cells(9, i + 1) = s2.[D13]
        Cells(10, i) = s2.[C14]
        Cells(10, i + 1) = s2.[D14]
        Cells(11, i) = s2.[C15]
        Cells(11, i + 1) = s2.[D15]
        Cells(12, i) = s2.[C16]
        Cells(12, i + 1) = s2.[D16]
        Cells(13, i) = s2.[C17]
        Cells(13, i + 1) = s2.[D17]
        Cells(14, i) = s2.[C18]
        Cells(14, i + 1) = s2.[D18]
        Cells(15, i) = s2.[C19]
        Cells(15, i + 1) = s2.[D19]
        i = son
    End If
Next
10:
End Sub