Veri doğrulamada makro kullanımı

[mersilen]

Merhabalar,
Veri doğrulamada liste yönteminde, listedeki elemanları makro içine yazarak belli bir alana, range("a1:a10") 'a veri doğrulama uygulaması yapılabiliniyor.
Benim istediğim aynı alana elemanlardan biri yazılınca veri doğrulama listesinden bunun düşmesi.
Kodu oluşturmaya çalıştım ama olmadı.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
myarray = Array(a, b, c, d, e)
If Intersect(Target, Range("a1:a100")) Is Nothing Then Exit Sub

For Each deger In myarray
If WorksheetFunction.CountIf(Range("a1:a10"), deger) < 1 Then veri1 = veri1 & ";" & deger
Next
veri = veri1 'veri = "b;c;e" şeklinde olacak
Range("a1:a10").Selection.Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=" & veri1

End If
End Sub

 

[halit3]

Konu hakkında bir şey yazmıyacağım sadece aşağıdaki linkde birşeyler var bir irdeleyin.

http://www.excel.web.tr/f48/makro-ile-acylyr-kutu-ve-veri-doorulama-t98954.html

 

[mersilen]

Sayın Halit bey,
Çalışmanız süper olmuş.

Bende Ömer beyin yardımı ile birkaç yıl önce nöbet listesi çalışmasında aynı mantığı 2-3 tablo üzerinden tasarlamıştım.O zaman aklıma böyle bir şeyin yapılacağı gelmemişti.Emeğinize sağlık diyorum.

Sizin çalışmadaki 6 mesajdaki dosyada Fsütunu ad tanımlamasındaki değerler sabit olduğuna göre (eklemede olabilir) bunları bir önceki mesajdaki myarray gibi birşeyin içine gömerek kullanmak daha iyi olmaz mı?Başka sayfaya bağımlı kalmayı önler diye düşünüyorum.Mümkünse tek bir liste için böyle bir çalışmada yapabilir misiniz?

 

[halit3]

Sayın Halit bey,
Çalışmanız süper olmuş.

Bende Ömer beyin yardımı ile birkaç yıl önce nöbet listesi çalışmasında aynı mantığı 2-3 tablo üzerinden tasarlamıştım.O zaman aklıma böyle bir şeyin yapılacağı gelmemişti.Emeğinize sağlık diyorum.

Sizin çalışmadaki 6 mesajdaki dosyada Fsütunu ad tanımlamasındaki değerler sabit olduğuna göre (eklemede olabilir) bunları bir önceki mesajdaki myarray gibi birşeyin içine gömerek kullanmak daha iyi olmaz mı?Başka sayfaya bağımlı kalmayı önler diye düşünüyorum.Mümkünse tek bir liste için böyle bir çalışmada yapabilir misiniz?

Aslında yukarıdaki mesajımda konuya katılım yapmıyacağımı belirtmiştim.

kod:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
sonsatır = 10
If Intersect(Target, Range("a1:a" & sonsatır)) Is Nothing Then Exit Sub
kat = 5 'açılan liste kusundaki toplam deger
ReDim deg(kat)
For k = 1 To kat
deg(k) = LCase(Split(Cells(1, k).Address, "$")(1))
Next k
veri = ""
sat = Target.Row
sut = Target.Column
Cells(sat, sut).Validation.Delete
For i = 1 To kat
son1 = 0
For j = 1 To sonsatır
If Cells(j, 1).Value = deg(i) Then
son1 = 1
Exit For
End If
Next j
If son1 = 0 Then
veri = veri & deg(i) & ","
End If
Next i
If veri <> "" Then
Cells(sat, sut).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=veri
End If
End Sub

 

[mersilen]

Halit bey ,
cevabınız için tekrar teşekkür ederim.Kod sorunsuz çalışıyor.

 

[halit3]

Halit bey ,
cevabınız için tekrar teşekkür ederim.Kod sorunsuz çalışıyor.

Yukarıdaki mesajdaki kodu daha esnek şekilde yeniden derledim.

 

[mersilen]

kod:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
sonsatır = 10
If Intersect(Target, Range("a1:a" & sonsatır)) Is Nothing Then Exit Sub
kat = 5 'açılan liste kusundaki toplam deger
ReDim deg(kat)
For k = 1 To kat
deg(k) = LCase(Split(Cells(1, k).Address, "$")(1))
Next k
veri = ""
sat = Target.Row
sut = Target.Column
Cells(sat, sut).Validation.Delete
For i = 1 To kat
son1 = 0
For j = 1 To sonsatır
If Cells(j, 1).Value = deg(i) Then
son1 = 1
Exit For
End If
Next j
If son1 = 0 Then
veri = veri & deg(i) & ","
End If
Next i
If veri <> "" Then
Cells(sat, sut).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=veri
End If
End Sub

Halit hocam buda güzel olmuş, hele açılır listedeki eleman sayısını ayarlamak güzel fikir.Kod sorunsuz çalışıyor.
Ancak listeye bir müdahale (isim atamak gibi) izin vermiyor.Aşağıdaki kodunuz benim amacımda daha kullanışlı.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("a1:a100")) Is Nothing Then Exit Sub
Dim deg(5)
deg(1) = "a"
deg(2) = "b"
deg(3) = "c"
deg(4) = "d"
deg(5) = "e"
veri = ""
sat1 = 0
sat = Target.Row
sut = Target.Column
Cells(sat, sut).Validation.Delete
For i = 1 To 5
son1 = 0
For j = 1 To 10
If Cells(j, 1).Value = deg(i) Then
son1 = 1
Exit For
End If
Next j
If son1 = 0 Then
sat1 = sat1 + 1
If sat1 = 1 Then
veri = deg(i)
Else
veri = veri & "," & deg(i)
End If
End If
Next i
If veri <> "" Then
Cells(sat, sut).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=veri
End If
End Sub

Ayrıca hastane nöbet listesi işi ile uğraştığım için, sizin nöbet listesi üzerine yaptığınız uygulamaları hem takip edip hemde anlamaya çalışıyorum.Listeyi her zaman otomatik dolturtamıyorum.En azından boş yerleri manuel doldurmada hatayı azaltmaya çalışıyorum.
Bizim açılan listedeki değerler isimlerden oluşacak .Açılan listedeki isimleri aynı gün üzerinde belli yerlere yazdıkça aynı gün satırındaki veri doğrulamadan düşürerek mükerrer yazılımı minimize etmeye çalışıyorum.Veri doğrulama kodlarınızdan feyz alarak kendimce bir kod geliştirdim.Bir gün için (bir satır aralığı veya sütun) bunda sorun yok.Manuel girişte mükerrerliğide uyarıyor.Bunu aya uyarlamam kaldı.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
myarray = Array("ali", "bekir", "can", "dursun", "emine")

If Intersect(Target, Range("a1:a10")) Is Nothing Then Exit Sub
veri1 = " " 'burası "" ise veri doğrulama listesi bitince açılmıyor
For Each deger In myarray
If WorksheetFunction.CountIf(Range("a1:a10"), deger) < 1 Then
If veri1 = "" Then veri1 = deger Else veri1 = veri1 & "," & deger

End If
Next
Range("a1:a10").Validation.Delete
Range("a1:a10").Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertWarning, Operator:=xlBetween, Formula1:=veri1
Range("a1:a10").Validation.ErrorMessage = "mükerrer giriş"
End Sub

 

[halit3]

Bana kalırsa kodun ismlerini sayfanın bir sütunundan alması daha sağlıklı olur her seferinde değişikliklerde koda müdahele etmeye gerek kalmaz.

Aşağıdaki kodun kırmızı yerlerine isimler nereden gelecekse o hücreleri tanımlayın.

kod:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
sonsatır = 10
If Intersect(Target, Range("a1:a" & sonsatır)) Is Nothing Then Exit Sub
kat = [COLOR=red]Worksheets(ActiveSheet.Name).Cells(Rows.Count, "a").End(3).Row[/COLOR]
ReDim deg(kat)
For k = 1 To kat
deg(k) = [COLOR=red]Worksheets(ActiveSheet.Name).Cells(k, "a").Value[/COLOR]
Next k
veri = ""
sat = Target.Row
sut = Target.Column
Cells(sat, sut).Validation.Delete
For i = 1 To kat
If WorksheetFunction.CountIf(Range(Cells(1, sut), Cells(Rows.Count, sut)), deg(i)) = 0 Then
veri = veri & deg(i) & ","
End If
Next i
If veri <> "" Then
Cells(sat, sut).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=veri
End If
End Sub

yada böyle bir kod:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("a1:a10")) Is Nothing Then Exit Sub
deg = Array("ali", "bekir", "can", "dursun", "emine")
veri = ""
sat = Target.Row
sut = Target.Column
Cells(sat, sut).Validation.Delete
For i = 1 To 5
If WorksheetFunction.CountIf(Range(Cells(1, sut), Cells(Rows.Count, sut)), deg(i - 1)) = 0 Then
veri = veri & deg(i - 1) & ","
End If
Next i
If veri <> "" Then
Cells(sat, sut).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertWarning, Operator:=xlBetween, Formula1:=veri
Cells(sat, sut).Validation.ErrorTitle = "Mükerrer giriş"
End If
End Sub

 

[mersilen]

Halit hocam tekrar teşekkür ederim,
haklısınız, kodları sizin dediğiniz gibi yapmak daha mantıklı olacak.
Veri listesi boşaldığı zamanda mükerrer giriş hataları vermeye devam edebilir mi?

 

[halit3]

Böyle olabilirmi ?
kod:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
sonsatır = 10
If Intersect(Target, Range("a2:a" & sonsatır)) Is Nothing Then Exit Sub
kat = Worksheets(ActiveSheet.Name).Cells(Rows.Count, "f").End(3).Row
ReDim deg(kat)
For k = 2 To kat
deg(k) = Worksheets(ActiveSheet.Name).Cells(k, "f").Value
Next k
veri = ""
sat = Target.Row
sut = Target.Column
Cells(sat, sut).Validation.Delete
For i = 2 To kat
If WorksheetFunction.CountIf(Range(Cells(1, sut), Cells(Rows.Count, sut)), deg(i)) = 0 Then
veri = veri & deg(i) & ","
End If
Next i
If veri <> "" Then
Cells(sat, sut).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertWarning, Operator:=xlBetween, Formula1:=veri
Cells(sat, sut).Validation.ErrorTitle = "Mükerrer giriş"
Else
MsgBox "hiç veri yok"
End If
End Sub

 

[halit3]

Buda farklı bir kod

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
sonsatır = 10
If Intersect(Target, Range("a2:a" & sonsatır)) Is Nothing Then Exit Sub
kat = Worksheets(ActiveSheet.Name).Cells(Rows.Count, "f").End(3).Row
ReDim deg(kat)
For k = 2 To kat
deg(k) = Worksheets(ActiveSheet.Name).Cells(k, "f").Value
Next k
veri = ""
sat = Target.Row
sut = Target.Column
Cells(sat, sut).Validation.Delete
For i = 2 To kat
If WorksheetFunction.CountIf(Range(Cells(1, sut), Cells(Rows.Count, sut)), deg(i)) = 0 Then
veri = veri & deg(i) & ","
End If
Next i
If veri <> "" Then
Cells(sat, sut).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertWarning, Operator:=xlBetween, Formula1:=veri
Cells(sat, sut).Validation.ErrorTitle = "Mükerrer giriş"
Else
Cells(sat, sut).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertWarning, Operator:=xlBetween, Formula1:=" "
Cells(sat, sut).Validation.InCellDropdown = False
Cells(sat, sut).Validation.InputTitle = "Dikkat"
Cells(sat, sut).Validation.InputMessage = "Listede veri kalmadı"
End If
End Sub

 

[mersilen]

Buda farklı bir kod

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
sonsatır = 10
If Intersect(Target, Range("a2:a" & sonsatır)) Is Nothing Then Exit Sub
kat = Worksheets(ActiveSheet.Name).Cells(Rows.Count, "f").End(3).Row
ReDim deg(kat)
For k = 2 To kat
deg(k) = Worksheets(ActiveSheet.Name).Cells(k, "f").Value
Next k
veri = ""
sat = Target.Row
sut = Target.Column
Cells(sat, sut).Validation.Delete
For i = 2 To kat
If WorksheetFunction.CountIf(Range(Cells(1, sut), Cells(Rows.Count, sut)), deg(i)) = 0 Then
veri = veri & deg(i) & ","
End If
Next i
If veri <> "" Then
Cells(sat, sut).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertWarning, Operator:=xlBetween, Formula1:=veri
Cells(sat, sut).Validation.ErrorTitle = "Mükerrer giriş"
Else
Cells(sat, sut).Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertWarning, Operator:=xlBetween, Formula1:=" "
Cells(sat, sut).Validation.InCellDropdown = False
Cells(sat, sut).Validation.InputTitle = "Dikkat"
Cells(sat, sut).Validation.InputMessage = "Listede veri kalmadı"
End If
End Sub

Halit hocam çok teşekkürler ,
en güzeli bu oldu.