veri aktarımı hk

[zamenya]

merhabalar evren hocamın yazdığı kodla saha1 sayfasından saha sayfasına veri aktarıyorum,aktarma sırasında diğer saha sayfada aynı veriden varsa mükerrer kayıt uyarısı verdrip işlemi durdura imkanımvarmı

Kod aşağıdaki gibidir

Private Sub CommandButton23_Click()

Dim s1 As Worksheet, s2 As Worksheet, adr1 As Range, adr2 As Range
Set s1 = Sheets("saha1")
Set s2 = Sheets("saha")
If MsgBox("[ " & DTPicker1.Value & _
" ] TARİHİNDEN SONRAKİ Verileriniz İşleme Alınmasını Onaylıyormusunuz ?" _
, vbYesNo + vbQuestion, Application.UserName) = vbNo Then Exit Sub
Application.ScreenUpdating = False
sat = s2.Cells(65536, "A").End(xlUp).Row + 1
For i = s1.Cells(65536, "A").End(xlUp).Row To 2 Step -1
If s1.Cells(i, "b").Value <> DTPicker1.Value Then
Set adr1 = s1.Range(s1.Cells(i, "a"), s1.Cells(i, "I"))
Set adr2 = s2.Range(s2.Cells(sat, "A"), s2.Cells(sat, "I"))
adr2.Value = adr1.Value
sat = sat + 1


End If
Next i

Application.ScreenUpdating = True
MsgBox "Verileriniz İşlenmiştir..!!", vbOKOnly + vbInformation, Application.UserName
End Sub

 

[zamenya]

başka kod deniyorum ama hep hata veriyor

 

[zamenya]

sayın hocalarım yukarda eklediğim koda nasıl bir uygulama yapıp mükerrer aktarımı engelleyebilirm

 

[zamenya]

sayın hocalarım lütfen yardım

 

[Orion1]

Mükerrerlik hangi sütunda kontrol edilecek.Tarihlerdemi edilecek ?

 

[zamenya]

sayın evren bey mükerrerlik kontrolü d dütününda gsm noda takip edilecek

 

[Orion1]

sayın evren bey mükerrerlik kontrolü d dütününda gsm noda takip edilecek

Aşağıdaki kodu denermisiniz?

Dim s1 As Worksheet, s2 As Worksheet, adr1 As Range, adr2 As Range
Set s1 = Sheets("saha1")
Set s2 = Sheets("saha")
If MsgBox("[ " & DTPicker1.Value & _
" ] TARİHİNDEN SONRAKİ Verileriniz İşleme Alınmasını Onaylıyormusunuz ?" _
, vbYesNo + vbQuestion, Application.UserName) = vbNo Then Exit Sub
Application.ScreenUpdating = False
sat = s2.Cells(65536, "A").End(xlUp).Row + 1
For i = s1.Cells(65536, "A").End(xlUp).Row To 2 Step -1
If s1.Cells(i, "b").Value <> DTPicker1.Value Then
    If WorksheetFunction.CountIf(Range("D2:D" & i), Cells(i, "D").Value) = 1 Then
        Set adr1 = s1.Range(s1.Cells(i, "a"), s1.Cells(i, "I"))
        Set adr2 = s2.Range(s2.Cells(sat, "A"), s2.Cells(sat, "I"))
        adr2.Value = adr1.Value
        sat = sat + 1
    End If
End If
Next i
Application.ScreenUpdating = True
MsgBox "Verileriniz İşlenmiştir..!!", vbOKOnly + vbInformation, Application.UserName

 

[zamenya]

sayın evren hocam çok teşekürler sizin yardımınızla bir evrak takip programı yapıyorum tam anlamıyla bittiğnde sitede yayınlayacağım desteğiniz için çok teşekkürler

 

[Orion1]

sayın evren hocam çok teşekürler sizin yardımınızla bir evrak takip programı yapıyorum tam anlamıyla bittiğnde sitede yayınlayacağım desteğiniz için çok teşekkürler

Rica ederim.
İyi çalışmalar.