Mükerrer Kaydı Onayla Yaptırmak. - reosman - 09/08/2021
Üstadlarım,
"İz" sayfasındaki verileri "İz_Arşiv" sayfasına aktarırken mükerrer kayıt varsa aktarmasın şeklinde kullanıyorum.
Şu şekilde bir talebim olacak,
Eğer sicil numarasına göre mükerrer kayıt olursa,
D sütununa göre mükerrer kaydı bulsun, D sütunu içeriğini (Sicil Numarasını) yazsın
ve onay istesin. Her mükerrer kayıt için EVET dersem aktarsın, HAYIR dersem aktarmasın.
Yardımlarınızı rica ediyorum. Saygılarımla.
RE: Mükerrer Kaydı Onayla Yaptırmak. - feraz - 10/08/2021
Merhaba.
Alttaki kodu deneyin.
Kodunuzda gereksiz olmuş dictionary.
Sub izarsiv()
Dim s1 As Worksheet, s2 As Worksheet, Dizi As Object
Dim son As Long, Veri As Variant, X As Long
Dim say As Long
Set s1 = Sheets("Ýz")
Set s2 = Sheets("Ýz_Arþiv")
son = s1.Cells(s1.Rows.Count, 1).End(3).Row
If son < 3 Then son = 3
Veri = s1.Range("A2:F" & son).Value
ReDim Liste(1 To UBound(Veri), 1 To 6)
For X = LBound(Veri, 1) To UBound(Veri, 1)
If WorksheetFunction.CountIf(s2.Range("D2" & Rows.Count), Veri(X, 4)) > 0 Then
If MsgBox(Veri(X, 4) & " sicil nolu kayit bulundu.Aktarilsin mi?", vbQuestion + vbYesNo, "Mükerrer") = vbYes Then
say = say + 1
Liste(say, 1) = Veri(X, 1)
Liste(say, 2) = Veri(X, 2)
Liste(say, 3) = Veri(X, 3)
Liste(say, 4) = Veri(X, 4)
Liste(say, 5) = Veri(X, 5)
Liste(say, 6) = CDate(Tarih)
End If
Else
say = say + 1
Liste(say, 1) = Veri(X, 1)
Liste(say, 2) = Veri(X, 2)
Liste(say, 3) = Veri(X, 3)
Liste(say, 4) = Veri(X, 4)
Liste(say, 5) = Veri(X, 5)
Liste(say, 6) = CDate(Tarih)
End If
Next
If say > 0 Then
s2.Cells(s2.Rows.Count, 1).End(3)(2, 1).Resize(UBound(Liste, 1), UBound(Liste, 2)) = Liste
MsgBox "Veri Aktarýmý Tamamlanmýþtýr." & vbCr & vbCr & _
Chr(10) & say & " Adet Kayýt Baþarýyla Aktarýldý!", vbInformation, "Aktarým Bilgisi"
Else
MsgBox "Aktarýlacak Uygun Kayýt Bulunamadý!", 16, "Mükerrer & Kayýt Yok"
End If
Set s1 = Nothing
Set s2 = Nothing
Set Dizi = Nothing
End Sub
RE: Mükerrer Kaydı Onayla Yaptırmak. - reosman - 10/08/2021
Çok teşekkür ederim hocam ilginize. Rabbim sizden razı ve memnun olsun. Sağolun varolun.
RE: Mükerrer Kaydı Onayla Yaptırmak. - feraz - 11/08/2021
Rica ederim,sizdende.
RE: Mükerrer Kaydı Onayla Yaptırmak. - reosman - 09/09/2021
Feraz hocam kod son şekliyle bu şekilde
Kod:
Sub izarsiv()
Dim s1 As Worksheet, s2 As Worksheet
Dim son As Long, Veri As Variant, X As Long
Dim say As Long, Tarih As Double
Tarih = Date
Set s1 = Sheets("İz")
Set s2 = Sheets("İz_Arşiv")
son = s1.Cells(s1.Rows.Count, 1).End(3).Row
If son < 2 Then son = 2
Veri = s1.Range("A2:F" & son).Value
ReDim Liste(1 To UBound(Veri), 1 To 6)
For X = LBound(Veri, 1) To UBound(Veri, 1)
If WorksheetFunction.CountIf(s2.Range("D2:D" & Rows.Count), Veri(X, 4)) > 0 Then
If MsgBox(Veri(X, 4) & " Sicil Numarası Arşiv Kayıtlarında Var!!" & vbCr & vbCr & _
"Mükerrer Olarak Tekrar Aktarılsın mı ?", vbQuestion + vbYesNo, "Mükerrer Kayıt Onayı") = vbYes Then
say = say + 1
Liste(say, 1) = Veri(X, 1)
Liste(say, 2) = Veri(X, 2)
Liste(say, 3) = Veri(X, 3)
Liste(say, 4) = Veri(X, 4)
Liste(say, 5) = Veri(X, 5)
Liste(say, 6) = CDate(Tarih)
End If
Else
say = say + 1
Liste(say, 1) = Veri(X, 1)
Liste(say, 2) = Veri(X, 2)
Liste(say, 3) = Veri(X, 3)
Liste(say, 4) = Veri(X, 4)
Liste(say, 5) = Veri(X, 5)
Liste(say, 6) = CDate(Tarih)
End If
Next
If say > 0 Then
s2.Cells(s2.Rows.Count, 1).End(3)(2, 1).Resize(UBound(Liste, 1), UBound(Liste, 2)) = Liste
MsgBox "Veri Aktarımı Tamamlanmıştır." & vbCr & vbCr & _
Chr(10) & say & " Adet Kayıt Başarıyla Aktarıldı!", vbInformation, "Aktarım Bilgisi"
Else
MsgBox "Aktarılacak Uygun Kayıt Bulunamadı!", 16, "Mükerrer & Kayıt Yok"
End If
Set s1 = Nothing
Set s2 = Nothing
End Sub
İz sayfasında herhangibir veri yokken 1 adet veri aktarıldı diyor ve İz_Arşiv sayfasına sadece tarih atıyor.
Bu hatanın düzeltilmesi için ne yapmam gerekir bayağı uğraştım beceremedim. Yardımınızı rica ediyorum.
RE: Mükerrer Kaydı Onayla Yaptırmak. - feraz - 09/09/2021
If son < 2 Then son = 2
yerine alttaki kodu deneyin.
If son < 2 Then Exit Sub
|