Sütunda Aynı Değeri Girdirmemek (Unique Cols)

Merhabalar,
Çalıştığım okulda ders planını sınıflara dağıtırken ihtiyaç olması halinde bir araştırma ve bir kaç düzenleme ile aşağıdaki excell vba kodlarını ortaya çıkardım. Kodların yaptığı şu : Her hangi bir sütunun, herhangi bir satırına veri girerken, bu veri bu sütunda başka satır varsa uyarı verdiriyor ve o hücrenizi kırmızı yapıyor. İnşallah işinize yarar diye ümit ediyorum.

İşte kodlar :

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

Dim LLoop As Integer
Dim LTestLoop As Integer

Dim Lrows As Integer
Dim LRange As String
Dim LChangedValue As String
Dim LTestValue As String
Dim sutun As String

'İlk 200 satırı tarayacak
Lrows = 200
LLoop = 2
sutun = Chr(ActiveCell.Column + 64)

While LLoop <= Lrows
LChangedValue = sutun & CStr(LLoop)

If Not Intersect(Range(LChangedValue), Target) Is Nothing Then
If Len(Range(LChangedValue).Value) > 0 Then

LTestLoop = 2
While LTestLoop <= Lrows
If LLoop <> LTestLoop Then
LTestValue = sutun & CStr(LTestLoop)
If Range(LChangedValue).Value = Range(LTestValue).Value Then
'Arka plan rengi kırmızı oluyor.
Range(LChangedValue).Interior.ColorIndex = 3
MsgBox Range(LChangedValue).Value & " değeri bu sütunda mevcut. Bulunduğu Satır : " & LTestLoop
Exit Sub
Else
Range(LChangedValue).Interior.ColorIndex = xlNone
End If

End If

LTestLoop = LTestLoop + 1
Wend

End If
End If

LLoop = LLoop + 1
Wend

End Sub

Yorum Yap


Not - Bunları KullanabilirsinizHTML tags and attributes:
<a href="" title=""> <abbr title=""> <acronym title=""> <b> <blockquote cite=""> <cite> <code> <del datetime=""> <em> <i> <q cite=""> <strike> <strong>