aktarmada mükerrer kaydı önlesin.

[yesilcan]

Sub aktar()
For a = 3 To 21 Step 2
If Sheets("Sheet1").Cells(a, "b") = 0 Then GoTo 10
sonsat = Sheets("data").Cells(65536, "A").End(xlUp).Row
If sonsat = 65535 Then
MsgBox "Sayfa doldu.Kayıt Yapılmadı.!!", vbCritical
Exit Sub
End If
Sheets("data").Cells(sonsat + 1, "A").Value = Sheets("Sheet1").Range("B1").Value
Sheets("data").Cells(sonsat + 1, "C").Value = Sheets("Sheet1").Range("B25").Value
Sheets("data").Cells(sonsat + 1, "C").Value = Sheets("Sheet1").Range("B25").Value
Sheets("data").Cells(sonsat + 1, "B").Value = Format(Time, "hh:mm")
Sheets("data").Cells(sonsat + 1, "G").Value = Sheets("Sheet1").Range("B23").Value
Sheets("data").Cells(sonsat + 1, "H").Value = Sheets("Sheet1").Range("B24").Value
Sheets("data").Cells(sonsat + 1, "I").Value = Sheets("Sheet1").Range("B26").Value
Sheets("data").Cells(sonsat + 1, "D").Value = Sheets("Sheet1").Cells(a, "b")
Sheets("data").Cells(sonsat + 1, "F").Value = Sheets("Sheet1").Cells(a + 1, "b")
10 Next
MsgBox "KAYIT AKTARILDI", vbOKOnly
End Sub


yukarıdaki kodda,aktarma yaptığım data sayfasında aynı tarihte aynı plakalı aracın bilgilerini aktarırken uyarı vermesini istiyorum.bu mümkünmü?
yukarıdaki kodlara hangi kodu eklemem gerekiyor.
şunun için istiyorum,aynı günde aynı plakalı aracı yüklememe izin vermesin.

arkadaşlar yardımınıza ihtiyacım var.

saygılarımla.

 

[merdineraslan6034]

bu kodları nasıl kullanıcam

 

[yesilcan]

Aktarmada MÜkerrer Kayit Önleme

ArkadaŞalar Örnek Dosyam Ekdedİr.
Yardimlarinizi Beklİyorum.

 

[Orion1]

Ekli dosyayı inceleyiniz.

Sub aktar()
[COLOR="Red"]For k = 2 To Sheets("DATA").Cells(65536, "A").End(xlUp).Row
    If CLng(CDate(Sheets("Sheet1").Range("B1").Value)) = CLng(CDate(Sheets("DATA").Cells(k, "A").Value)) _
    And Sheets("Sheet1").Range("B24").Value = Sheets("DATA").Cells(k, "H").Value Then
        If MsgBox("Bu tarihte ve Bu Plakada Kayıt Dağa Önce Yapılmış.!" & vbLf & _
        "Yinede Kayıt Etmek istiyormusunuz..??", vbYesNo, "KAYIT VAR..!!") = vbNo Then
            MsgBox "Kayıt Yapılmadı..!!", vbCritical, "Kayıt Yapılmadı..!!"
            Exit Sub
            Else
            GoTo kayit
        End If
    End If
Next k
kayit:[/COLOR]
For a = 3 To 21 Step 2
If Sheets("Sheet1").Cells(a, "b") = 0 Then GoTo 10
sonsat = Sheets("data").Cells(65536, "A").End(xlUp).Row
If sonsat = 65535 Then
MsgBox "Sayfa doldu.Kayıt Yapılmadı.!!", vbCritical
Exit Sub
End If
Sheets("data").Cells(sonsat + 1, "A").Value = Sheets("Sheet1").Range("B1").Value
Sheets("data").Cells(sonsat + 1, "C").Value = Sheets("Sheet1").Range("B25").Value
Sheets("data").Cells(sonsat + 1, "C").Value = Sheets("Sheet1").Range("B25").Value
Sheets("data").Cells(sonsat + 1, "B").Value = Format(Time, "hh:mm")
Sheets("data").Cells(sonsat + 1, "G").Value = Sheets("Sheet1").Range("B23").Value
Sheets("data").Cells(sonsat + 1, "H").Value = Sheets("Sheet1").Range("B24").Value
Sheets("data").Cells(sonsat + 1, "I").Value = Sheets("Sheet1").Range("B26").Value
Sheets("data").Cells(sonsat + 1, "D").Value = Sheets("Sheet1").Cells(a, "b")
Sheets("data").Cells(sonsat + 1, "F").Value = Sheets("Sheet1").Cells(a + 1, "b")
10 Next
MsgBox "KAYIT AKTARILDI", vbOKOnly
End Sub

 

[yesilcan]

ORION2 hocam ilgin için teşekkür ederim

hocam aktar tuşuna bastığımda tekrar kaydetmek isteyip istemediğimi sormasın
aktarma işlemini yapmasın.

bu mümkünmü ?

 

[Orion1]

hocam aktar tuşuna bastığımda tekrar kaydetmek isteyip istemediğimi sormasın
aktarma işlemini yapmasın.

bu mümkünmü ?

Ekli dosyayı inceleyiniz.

Sub aktar()
[COLOR="Red"]For k = 2 To Sheets("DATA").Cells(65536, "A").End(xlUp).Row
    If CLng(CDate(Sheets("Sheet1").Range("B1").Value)) = CLng(CDate(Sheets("DATA").Cells(k, "A").Value)) _
    And Sheets("Sheet1").Range("B24").Value = Sheets("DATA").Cells(k, "H").Value Then
            MsgBox "Kayıt Yapılmadı..!!" & vbLf & "Bu Kayıt Dağa Önce Girilmiş..!!!", vbCritical, "Kayıt Yapılmadı..!!"
            Exit Sub
    End If
Next k[/COLOR]
For a = 3 To 21 Step 2
If Sheets("Sheet1").Cells(a, "b") = 0 Then GoTo 10
sonsat = Sheets("data").Cells(65536, "A").End(xlUp).Row
If sonsat = 65535 Then
MsgBox "Sayfa doldu.Kayıt Yapılmadı.!!", vbCritical
Exit Sub
End If
Sheets("data").Cells(sonsat + 1, "A").Value = Sheets("Sheet1").Range("B1").Value
Sheets("data").Cells(sonsat + 1, "C").Value = Sheets("Sheet1").Range("B25").Value
Sheets("data").Cells(sonsat + 1, "C").Value = Sheets("Sheet1").Range("B25").Value
Sheets("data").Cells(sonsat + 1, "B").Value = Format(Time, "hh:mm")
Sheets("data").Cells(sonsat + 1, "G").Value = Sheets("Sheet1").Range("B23").Value
Sheets("data").Cells(sonsat + 1, "H").Value = Sheets("Sheet1").Range("B24").Value
Sheets("data").Cells(sonsat + 1, "I").Value = Sheets("Sheet1").Range("B26").Value
Sheets("data").Cells(sonsat + 1, "D").Value = Sheets("Sheet1").Cells(a, "b")
Sheets("data").Cells(sonsat + 1, "F").Value = Sheets("Sheet1").Cells(a + 1, "b")
10 Next
MsgBox "KAYIT AKTARILDI", vbOKOnly
End Sub

 

[yesilcan]

hocam çok çok teşekkür ederim.

affınıza sığınarak son bir soru daha sorabilirmiyim.
bu kodları sayfada butona atadım.
fakat bu butonda üçmacro atadım.

yani ,

sub üçmacro ()
call aktar
call kaydet
call yazdır
end sub

yani butona bastığımda önce sizin gönderdiğiniz aktar kodu çalışıyor sonra diğerleri.
ama aynı tarihte aynı plakalı aracı yüklediğimin uyarı geliyor.fakat diğer macrolar çalışmaya devam ediyor.
aynı günde aynı plakayı 2.kez yükleye kalktığımda bu butondaki hiçbir macro çalışmasın.

bu nasıl olacak.

 

[Orion1]

Ücmakro prosedürünün ilk satırlarına aktar makrosunun kırmızı ile yazılmış kodları KESİP yapıştırınız.
İşlem tamam.

 

[yesilcan]

hocam çok teşekkür ederim.

hocam ilgin ve alakan için sonsuz teşekkürler.

çalışma hayatında başarılar.

 

[Orion1]

hocam ilgin ve alakan için sonsuz teşekkürler.

çalışma hayatında başarılar.

Rica ederim.
Bilmukabele

 

[hsayar]

yada onları

Sub Mkrr_Kontrol()

End Sub

arasına yazıp kodlarda Subların altına

Call Mkrr_Kontrol

de yazabilirsin