Soru VBA koduna ekleme yapma

[sirkülasyon]

Dim s1 As Worksheet, S2 As Worksheet
Dim sS1 As Integer, sS2 As Integer
Dim Son As Long
Set s1 = ThisWorkbook.Worksheets("Personel")
Set S2 = ThisWorkbook.Worksheets("Puantaj")
sS1 = s1.Range("A" & Rows.Count).End(xlUp).Row
sS2 = S2.Range("A" & Rows.Count).End(xlUp).Row
veri = 0
For i = 2 To sS1
    If WorksheetFunction.CountIfs(S2.Range("D1:D" & sS2), s1.Cells(i, "D"), S2.Range("E1:E" & sS2), s1.Cells(i, "E"), _
                                    S2.Range("F1:F" & sS2), s1.Cells(i, "F"), S2.Range("T1:T" & sS2), s1.Cells(i, "t"), _
                                    S2.Range("U1:U" & sS2), s1.Cells(i, "U")) = 0 Then
        Application.ScreenUpdating = False
            veri = veri + 1
            s1.Range("A" & i & ":X" & i).Copy
            With S2.Cells(sS2 + veri, "A")
                .PasteSpecial xlValues
                .PasteSpecial xlFormats
            End With
            S2.Range("A2:Z" & sS2 + 1).Sort S2.Range("A2"), xlAscending
            S2.Select
            S2.Range("A1").Select
            s1.Select
            Application.CutCopyMode = False
        Application.ScreenUpdating = True
    End If
Next
If veri = 0 Then
    MsgBox "Aktarılacak veri bulunamadı!", vbExclamation
    Application.ScreenUpdating = True
Else
    MsgBox veri & " adet veri aktarıldı!", vbInformation
End If
Set s1 = Nothing
Set S2 = Nothing

Personel Sayfası H3:H sütununda tarih var ise tarih olan satırları aktarsın . Diğerlerini aktarmasın... kriterine göre düzenlememe yardımcı olabilir misiniz

 

[maliex]

Dim s1 As Worksheet, S2 As Worksheet
Dim sS1 As Integer, sS2 As Integer
Dim Son As Long
Set s1 = ThisWorkbook.Worksheets("Personel")
Set S2 = ThisWorkbook.Worksheets("Puantaj")
sS1 = s1.Range("A" & Rows.Count).End(xlUp).Row
sS2 = S2.Range("A" & Rows.Count).End(xlUp).Row
veri = 0
For i = 2 To sS1
    If WorksheetFunction.CountIfs(S2.Range("D1:D" & sS2), s1.Cells(i, "D"), S2.Range("E1:E" & sS2), s1.Cells(i, "E"), _
                                    S2.Range("F1:F" & sS2), s1.Cells(i, "F"), S2.Range("T1:T" & sS2), s1.Cells(i, "t"), _
                                    S2.Range("U1:U" & sS2), s1.Cells(i, "U")) = 0 And IsDate(s1.Cells(i, "H").Value) Then
        Application.ScreenUpdating = False
            veri = veri + 1
            s1.Range("A" & i & ":X" & i).Copy
            With S2.Cells(sS2 + veri, "A")
                .PasteSpecial xlValues
                .PasteSpecial xlFormats
            End With
            S2.Range("A2:Z" & sS2 + 1).Sort S2.Range("A2"), xlAscending
            S2.Select
            S2.Range("A1").Select
            s1.Select
            Application.CutCopyMode = False
        Application.ScreenUpdating = True
    End If
Next
If veri = 0 Then
    MsgBox "Aktarılacak veri bulunamadı!", vbExclamation
    Application.ScreenUpdating = True
Else
    MsgBox veri & " adet veri aktarıldı!", vbInformation
End If
Set s1 = Nothing
Set S2 = Nothing