Soru hücrden sayfaya alt alta aktarma esnasında mükerrer kontrol hatalı

[sirkülasyon]

Application.ScreenUpdating = False

Dim d As Object, i As Long, Son As Long, deg
Set d = CreateObject("Scripting.Dictionary")

Son_Dolu_Satir = Sheets("Sayfa3").Range("C65536").End(xlUp).Row
For i = 2 To Cells(Rows.Count, "c").End(xlUp).Row
deg = Cells(i, "c") & "|" & Cells(i, "d") & "|" & Cells(i, "e") & "|" & Cells(i, "f") & "|" & Cells(i, "g")
If Not d.exists(deg) Then
d.Add deg, Nothing
Else
MsgBox "Bu Kayıt Daha Önce Girilmiş", vbInformation, "MEVCUT KAYIT UYARISI"
Exit Sub
End If
Next i
Bos_Satir = Son_Dolu_Satir + 1
Sheets("Sayfa3").Range("B" & Bos_Satir).Value = Application.WorksheetFunction.Max(Sheets("Sayfa3").Range("B:B")) + 1
Sheets("Sayfa3").Range("C" & Bos_Satir).Value = Sheets("Sözleşme").Range("E2").Value
Sheets("Sayfa3").Range("D" & Bos_Satir).Value = Sheets("Sözleşme").Range("D92").Value
Sheets("Sayfa3").Range("E" & Bos_Satir).Value = Sheets("Sözleşme").Range("E2").Value & " Lojmanı"
Sheets("Sayfa3").Range("F" & Bos_Satir).Value = Sheets("Sözleşme").Range("E6").Value
Sheets("Sayfa3").Range("G" & Bos_Satir).Value = Sheets("Sözleşme").Range("E7").Value & Chr(10) & Sheets("Sözleşme").Range("E8").Value
Sheets("Sayfa3").Range("H" & Bos_Satir).Value = Format(Sheets("Sözleşme").Range("G92").Value, "dd.mm.yyyy")
Sheets("Sayfa3").Range("I" & Bos_Satir).Value = "2"
Sheets("Sayfa3").Range("J" & Bos_Satir).Value = "0"
Sheets("Sayfa3").Range("K" & Bos_Satir).Value = "0"
Sheets("Sayfa3").Range("L" & Bos_Satir).Value = Format(Day(Sheets("Sayfa3").Range("H" & Bos_Satir).Value) & "." & Month(Sheets("Sayfa3").Range("H" & Bos_Satir).Value) & "." & Year(Sheets("Sayfa3").Range("H" & Bos_Satir).Value) + 2, "dd.mm.yyyy")
 For i = 2 To Sheets("Sayfa3").Range("C65530").End(3).Row
On Error Resume Next
If (Sheets("Sayfa3").Range("C" & i).Value <> "") Then
Sheets("Sayfa3").Range("B" & i) = i - 1
End If
Next i
'End If

'    Dim Son As Long
'    Sheets("Sayfa3").Range("C3:N" & Rows.Count).Borders.LineStyle = xlNone
'    Son = Evaluate("LOOKUP(2,1/((C:C<>"""")*(C:C>0)),ROW(C:C))")
'    Sheets("Sayfa3").Range("C3:N" & Son).Borders.LineStyle = 1

Sheets("Sayfa3").Select
MsgBox "Kayıt işlemi tamamlandı.", vbInformation, "UYARI"
MsgBox "Eksik bilgi. Lütfen eksikleri tamamlayıp kaydediniz. ", vbExclamation, "UYARI"
Application.ScreenUpdating = True

Üstadım
1 - Sözleşme Sayfasından aktarma yaptığım zaman aktarmıyor. Sayfa3' de aktar dediğimde aktarıyor.
2 -
' Dim Son As Long
' Sheets("Sayfa3").Range("C3:N" & Rows.Count).Borders.LineStyle = xlNone
' Son = Evaluate("LOOKUP(2,1/((C:C<>"""")*(C:C>0)),ROW(C:C))")
' Sheets("Sayfa3").Range("C3:N" & Son).Borders.LineStyle = 1
kısmı hata veriyor.
3 - Mükerrer kontrol 2. satırdan itibaren yapması lazımken yapmıyor.

Rica etsem yardımcı olabilmeniz mümkün mü?

 

[Korhan Ayhan]

Klasik bir soru yönelteceğim...

Örnek dosya paylaşırmısınız..

 

[sirkülasyon]

Asıl Dosya Ektedir Korhan Abi

 

[Korhan Ayhan]

Siz mükerrer kayıt kontrolünü neye göre yapıyorsunuz?

 

[sirkülasyon]

Dim d As Object, i As Long, Son As Long, deg
Set d = CreateObject("Scripting.Dictionary")
Son_Dolu_Satir = Sheets("Sayfa3").Range("C65536").End(xlUp).Row
For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
deg = Cells(i, "c") & "|" & Cells(i, "d") & "|" & Cells(i, "e") & "|" & Cells(i, "f") & "|" & Cells(i, "g")
If Not d.exists(deg) Then
d.Add deg, Nothing
Else
MsgBox "Bu Kayıt Daha Önce Girilmiş", vbInformation, "MEVCUT KAYIT UYARISI"
Exit Sub
End If
Next i

Sayfa3 C,D,E,F,G sütunları üzerinden Korhan Abim

 

[Korhan Ayhan]

Orasını anladım. Fakat neyle neyi kıyaslayıp mükerrer olduğuna karar veriyorsunuz?

 

[sirkülasyon]

Korhan Abi,
Sözleşme Sayfası E2
Sözleşme Sayfası E6
Sözleşme Sayfası E7 & E8
Sözleşme Sayfası G92
Sözleşme Sayfası D92
hücrelerinin aynısı Sayfa3' e aktarılırsa mükerrer olarak gör diyorum

 

[Korhan Ayhan]

Kurduğunuz döngüde böyle bir kıyaslamayı ben göremiyorum.