Dört kolondaki veride mükerrer ise uyarması

[bduru]

Aynı arazinin satılması veya başkasına kira verilmesine karşın aynı arazi için tekrar kredi verilmesini engellemek için böyle bir makroya ihtiyaç duydum. Halen kullanmakta olduğum excel dosyasından şuan ihtiyacım olan makro için gerekli olan bölümlerini ekteki dosyaya yerleştirdim. Ekteki dosyada (her satırda bir müşteri olarak) AB32 satırdan itibaren daha önce verileri girilmiş ve değerlendirmeye alınmış 12 arazi yan yana(altalta 144 müşteri için) yer almaktadır. Benim istediğim; U3-14 satırındaki köyü,V3-14 satırındaki mevkisi, AC3-14 satırdaki adası(bazen olmuyor) ve AC3-14 satırındaki parsel numaralarının AB32 satırdan itibaren yan yana 12 arazi(alt alta 144satı) içinde bir butonla tarama yaparak bu dört olasılığı da uyuşan arazi için Örneğin "23.arazi daha önce kredilendirdi" mesajı ile uyarmasıdır. Saygılar İyi geceler

Not: Ekteki dosya 144 müşteri içindi normalda 2binin üzerinde

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu sayfanızın kod bölümüne uygualyıp denermisiniz.

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim BUL As Range, ADRES As String
    If Intersect(Target, Range("U3:V14,AC3:AD14")) Is Nothing Then Exit Sub
    If Cells(Target.Row, "AC") <> "" Then
        If Cells(Target.Row, "U") <> "" And Cells(Target.Row, "V") <> "" And Cells(Target.Row, "AD") <> "" Then
            Set BUL = Range("AB32:IV65536").Find(Cells(Target.Row, "U"), LookAt:=xlWhole)
            If Not BUL Is Nothing Then
            ADRES = BUL.Address
            Do
                If BUL.Offset(0, 1) = Cells(Target.Row, "V") And BUL.Offset(0, 8) = Cells(Target.Row, "AC") And BUL.Offset(0, 9) = Cells(Target.Row, "AD") Then
                    MsgBox Cells(25, BUL.Column) & " daha önce " & BUL.Row[COLOR=red] - 31[/COLOR] & ". satırda kredilendirildi !", vbCritical
                    Cells(Target.Row, "U") = ""
                    Cells(Target.Row, "V") = ""
                    Cells(Target.Row, "AC") = ""
                    Cells(Target.Row, "AD") = ""
                    Cells(Target.Row, "U").Select
                    Exit Do
                End If
            Set BUL = Range("AB32:IV65536").FindNext(BUL)
            Loop While Not BUL Is Nothing And BUL.Address <> ADRES
            End If
        End If
    Else
        If Cells(Target.Row, "U") <> "" And Cells(Target.Row, "V") <> "" And Cells(Target.Row, "AD") <> "" Then
            Set BUL = Range("AB32:IV65536").Find(Cells(Target.Row, "U"), LookAt:=xlWhole)
            If Not BUL Is Nothing Then
            ADRES = BUL.Address
            Do
                If BUL.Offset(0, 1) = Cells(Target.Row, "V") And BUL.Offset(0, 9) = Cells(Target.Row, "AD") Then
                    MsgBox Cells(25, BUL.Column) & " daha önce " & BUL.Row[COLOR=red] - 31[/COLOR] & ". satırda kredilendirildi !", vbCritical
                    Cells(Target.Row, "U") = ""
                    Cells(Target.Row, "V") = ""
                    Cells(Target.Row, "AD") = ""
                    Cells(Target.Row, "U").Select
                    Exit Do
                End If
            Set BUL = Range("AB32:IV65536").FindNext(BUL)
            Loop While Not BUL Is Nothing And BUL.Address <> ADRES
            End If
        End If
    End If
 
    Set BUL = Nothing
End Sub

 

[bduru]

Kısmi olarak işimi gördü mükerrer olanın kaçıncı arazide olduğunu veriyor kaçıncı satır olduğunu da verse daha iyi olacak

 

[Korhan Ayhan]

Selamlar,

Üstteki mesajımdaki koda satır bilgisinide ekledim. İncelermisiniz.

Eğer kayıdın orjinal satır numarasını görmek isterseniz kodda kırmızı renkle belirttiğim (- 31) değerlerini silin.