• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

aktarmada mükerrer kaydı önlesin.

Y

yesilcan

Katılım
22 Ocak 2007
Mesajlar
321
Excel Vers. ve Dili
offıce 2003
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.
 
Aktarmada MÜkerrer Kayit Önleme

ArkadaŞalar Örnek Dosyam Ekdedİr.
Yardimlarinizi Beklİyorum.
 
Ekli dosyayı inceleyiniz.:cool:
Kod: 
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
 
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ü ?
 
yesilcan' Alıntı:
hocam aktar tuşuna bastığımda tekrar kaydetmek isteyip istemediğimi sormasın
aktarma işlemini yapmasın.

bu mümkünmü ?
Genişletmek için tıkla ...
Ekli dosyayı inceleyiniz.:cool:
Kod: 
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
 
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.
 
Ü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.:cool:
 
hocam çok teşekkür ederim.

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

çalışma hayatında başarılar.
 
yada onları
Kod: 
Sub Mkrr_Kontrol()

End Sub

arasına yazıp kodlarda Subların altına
Kod: 
Call Mkrr_Kontrol
de yazabilirsin
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst