Dinamik Veri Doğrulama

[hamza02]

Sub Test()
Dim syfGiriş As Worksheet
Dim syfSuçlar As Worksheet
Dim Bak As Long
Dim Liste As String

Set syfGiriş = ThisWorkbook.Sheets("Giriş")
Set syfSuçlar = ThisWorkbook.Sheets("Suçlar")

For Bak = 1 To syfSuçlar.Cells(Rows.Count, "A").End(xlUp).Row
If syfSuçlar.Cells(Bak, "B") = "" Then
If Liste = "" Then
Liste = syfSuçlar.Cells(Bak, "A")
Else
Liste = Liste & ", " & syfSuçlar.Cells(Bak, "A")
End If
End If
Next

With ThisWorkbook.Sheets("Giriş").Range("C15")
.Validation.Delete
.Validation.Add xlValidateList, Formula1:=Liste
End With
End Sub


Değerli arkadaşlar merhaba,
Suçlar sayfası A sütununda Suç isimleri var,
Giriş Sayfası C15, C19, C23, C27, C31, C35, C39, C43, C47, C51 hücrelerine veri doğrulama ile Suçlar sayfası A sütunundaki Suç isimlerinden seçim yapıyorum.
Bu işlemi yukarıdaki makro ile yapmaya çalıştım ama maalesef yapamadım.

Yapmak istediğim Giriş sayfasındaki belirttiğim bu 10 ayrı hücrenin herhangi birine harf veya kelime girdiğimde bu harf veya kelimenin içinde geçtiği Suçları göstermesi.
Yardımlarınız için şimdiden teşekkür ederim.

 

[hamza02]

Dosya ektedir

İndir Veri Girişi xlsm

Dosyayı indir Veri Girişi xlsm

dosya.co

 

[Korhan Ayhan]

Ne gibi bir sorun yaşadınız?

 

[hamza02]

Giriş Sayfası C15 hücresi içinde veri doğrulama olarak Suçlar sayfası A sütunundaki verileri birleşik gösteriyor.

 

[Korhan Ayhan]

Çünkü Suçlar sayfasında A sütunundaki hücrelerde VİRGÜL kullanılmış. Makroda veri doğrulama listesinde ayıraçta virgül olduğu için işler karışıyor...

Makro yerine yerleşik veri doğrulama ile yapmanızı tavsiye ederim.

Eğer makro ile yapmak istiyorsanız virgülleri geçici (Chr(130) görsel olarak virgüle benzer) bir karakter ile değiştirip doğrulama listesini oluşturduktan sonra kullanıcı listeden seçim yaptıktan sonra veri içindeki bu geçici karakteri tekrar virgülle değiştirip orjinal haline geri getirilebilir.

Aşağıdaki kod blokları bu işlemleri yapar...

Modül Kodu;

Sub Edit_Data_Validation_List()
    Dim S1 As Worksheet
    Dim S2 As Worksheet
    Dim Veri As Variant
    Dim Dizi As Variant
    Dim Liste As String
    Dim X As Long, Y As Long
    Dim Rng As Variant
   
    Set S1 = ThisWorkbook.Sheets("Giriş")
    Set S2 = ThisWorkbook.Sheets("Suçlar")
   
    Veri = S2.Range("A1:A" & S2.Cells(S2.Rows.Count, "A").End(xlUp).Row).Value
   
    ReDim Dizi(1 To 1)
   
    For X = 1 To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            Y = Y + 1
            ReDim Preserve Dizi(1 To Y)
            Dizi(Y) = Replace(Veri(X, 1), ",", Chr(130))
        End If
    Next
   
    Liste = Join(Dizi, ",")
   
    With S1.Range("C15,C19,C23,C27,C31,C35,C39,C43,C47,C51").Validation
        .Delete
        If Liste <> "" Then .Add xlValidateList, Formula1:=Liste
    End With

    Set S1 = Nothing
    Set S2 = Nothing
End Sub

Giriş Sayfası Kodu;

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim GeciciKarakter As String
    Dim HedefHücreler As Range
    Dim Hücre As Range
   
    GeciciKarakter = Chr(130) ' ‚
   
    ' 1. TARİH EKLEME (C2)
    If Not Intersect(Target, Range("C2")) Is Nothing Then
        If Trim(Target.Value) <> "" Then
            Application.EnableEvents = False
            Range("C10").Value = Date
            Range("C11").Value = Time
            Range("C10").NumberFormat = "dd.mm.yyyy"
            Range("C11").NumberFormat = "hh:mm"
            Application.EnableEvents = True
        End If
    End If
   
    ' 2. VERİ DOĞRULAMA DÜZELTME (Liste hücreleri)
    Set HedefHücreler = Me.Range("C15,C19,C23,C27,C31,C35,C39,C43,C47,C51")
   
    If Not Intersect(Target, HedefHücreler) Is Nothing Then
        On Error Resume Next
        Application.EnableEvents = False
       
        For Each Hücre In Intersect(Target, HedefHücreler)
            If Not IsError(Hücre.Value) Then
                If InStr(Hücre.Value, GeciciKarakter) > 0 Then
                    Hücre.Value = Replace(Hücre.Value, GeciciKarakter, ",")
                End If
            End If
        Next Hücre
       
        Application.EnableEvents = True
        On Error GoTo 0
    End If
End Sub