Koşula Bağlı Sayfalar Arası Kopyalama

[nurioruc60]

https://s6.dosya.tc/server20/t9kodx/gunluk_rapor.xlsx.html


günlük rapor k1 hücresindeki değeri oda1 ve oda2 sayfasında bulunan D sütünunda bulacak ve günlük rapordaki gibi sırasıyla ilgili sayfaya kopyalayacak bir kod arıyorum şartlı kopyalama kısmını çözemedim makrolar ile ilk defa çalışıyorum.

Saygılar.

 

[ÖmerBey]

Merhaba,
Örnek dosyanız için deneyiniz.

Sub kod()
Dim s1 As Worksheet, s2 As Worksheet
Dim trh As Date
Dim a As Integer
Dim msj As String
Set s1 = Sheets("günlük rapor")
trh = s1.Range("K1").Value
For a = 3 To s1.Cells(Rows.Count, "A").End(3).Row
    On Error Resume Next
    
    Set s2 = Nothing
    If s1.Cells(a, "A") = "1. oda" Then
        Set s2 = Sheets("ODA1")
    ElseIf s1.Cells(a, "A") = "2. oda" Then
        Set s2 = Sheets("ODA2")
    ElseIf s1.Cells(a, "A") = "3. oda" Then
        Set s2 = Sheets("ODA3")
    ElseIf s1.Cells(a, "A") = "4. oda" Then
        Set s2 = Sheets("ODA4")
    End If
    
    On Error GoTo 0
    If Not s2 Is Nothing Then
        For b = 5 To s2.Cells(Rows.Count, "D").End(3).Row
            If s2.Cells(b, "D").Value = trh Then
                s2.Range(s2.Cells(b, "E"), s2.Cells(b, "N")).Value = s1.Range(s1.Cells(a, "B"), s1.Cells(a, "K")).Value
                GoTo 1
            End If
        Next
        msj = msj & s2.Name & " tablosunda " & trh & " tarihi yok." & vbLf
    Else
        msj = msj & s1.Cells(a, "A") & " için sayfa atanmamış." & vbLf
    End If
1
Next
MsgBox IIf(msj = "", "İşlem başarılı.", "Hata oluştu:" & vbLf & msj)
End Sub