Soru Veri doğrulamaya hücredeki veriyi ekleme

[emreeyy]

Merhaba "E" hücremde virgülle ayrılmış bir liste mevcut bunu "F" hücresinde veri doğrulama listesi olarak açılır bir şekilde nasıl gösterebilirim?

 

[Ömer]

Merhaba,

Sayfanın kod bölümüne kopyalayın.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim d, son As Long, i As Byte, dizi(), s As Byte
    
    son = Cells(Rows.Count, "E").End(xlUp).Row

    If Intersect(Target, Range("F2:F" & son)) Is Nothing Then Exit Sub
    
    With Target
        If .Count > 1 Then Exit Sub
        .Validation.Delete
        d = Split(Cells(.Row, "E"), ",")
        For i = 0 To UBound(d)
            ReDim Preserve dizi(s)
            dizi(s) = d(i)
            s = s + 1
        Next i
        .Validation.Add Type:=xlValidateList, Formula1:=Join(dizi, ",")
    End With
    
End Sub

 

[emreeyy]

Merhaba,

Sayfanın kod bölümüne kopyalayın.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim d, son As Long, i As Byte, dizi(), s As Byte
   
    son = Cells(Rows.Count, "E").End(xlUp).Row

    If Intersect(Target, Range("F2:F" & son)) Is Nothing Then Exit Sub
   
    With Target
        If .Count > 1 Then Exit Sub
        .Validation.Delete
        d = Split(Cells(.Row, "E"), ",")
        For i = 0 To UBound(d)
            ReDim Preserve dizi(s)
            dizi(s) = d(i)
            s = s + 1
        Next i
        .Validation.Add Type:=xlValidateList, Formula1:=Join(dizi, ",")
    End With
   
End Sub

Hocam bunu ekledim fakat
Worksheet_SelectionChange
nerede tetikleniyor çözümleyemedim.
Oradaki virgüllü listeyi aşağıdaki kullanıcı tanımlı fonksiyon ile oluşturuyorum.
"D" sütunumda ürünler var veri doğrulama ile o ürünü seçtiğimde "E" Sütunu için aşağıdaki kod çalışıp operasyonları virgül ile ayırarak getiriyor.
bende "F" sütununa veri doğrulama ile o virgüllü listeyi açılır kutu şeklinde getirmek istiyorum.

Function MultipleLookupNoRept(Lookupvalue As String, LookupRange As Range, ColumnNumber As Integer)
'Updateby Extendoffice
    Dim xDic As New Dictionary
    Dim xRows As Long
    Dim xStr As String
    Dim i As Long
    

    
    On Error Resume Next
    xRows = LookupRange.Rows.Count
    For i = 1 To xRows
        If LookupRange.Columns(1).Cells(i).Value = Lookupvalue Then
            xDic.Add LookupRange.Columns(ColumnNumber).Cells(i).Value, ""
        End If
    Next
    xStr = ""
    MultipleLookupNoRept = xStr
    If xDic.Count > 0 Then
        For i = 0 To xDic.Count - 1
            xStr = xStr & xDic.Keys(i) & ","
            
        Next
        
        MultipleLookupNoRept = Left(xStr, Len(xStr) - 1)
        

    End If
End Function

 

[emreeyy]

Yukarıdaki gönderiyi düzenleyemediğim için yazıyorum.
Aslında kullanıcı tanımlı fonksiyonu direk hücreye yazmak yerine oraya açılır liste eklemesini sağlayabilsem 2 kere işçilik yapmamış olacağım.

 

[Ömer]

Örnek dosya ekleyerek açıklayınız.

Dosya Yükle - Dosya Upload

Dosyalarınızı ücretsiz yükleyebilir ve paylaşabilirsiniz. Dosya yükleme, Dosya Upload ücretsiz.

dosya.co

 

[emreeyy]

Örnek dosya ekleyerek açıklayınız.

Dosya Yükle - Dosya Upload

Dosyalarınızı ücretsiz yükleyebilir ve paylaşabilirsiniz. Dosya yükleme, Dosya Upload ücretsiz.

dosya.co

İndir Giriş

Dosyayı indir Giriş

dosya.co

Günaydın,
buyrun hocam

 

[Korhan Ayhan]

Aradaki E sütunu duracak mı?

 

[emreeyy]

Aradaki E sütunu duracak mı?

Hocam e ye koyduğum formül yerine e ye direk açılır liste halinde gelse mükemmel olur.2 defa işlem yapmamış oluruz.

 

[Korhan Ayhan]

Bu durumda F sütunu silinecek sanırım..

 

[emreeyy]

Bu durumda F sütunu silinecek sanırım..

evet hocam listeyi direkt ekletebilirsek o sütuna gerek kalmayacak.Ondan sonraki sütunlar önemli değil zaten yeniden yapabilirim.

 

[Korhan Ayhan]

Merhaba,

Dosyanızda aradaki E sütunu sildikten sonra aşağıdaki kodu sayfanızın kod bölümüne uygulayıp deneyiniz.

Kod ek olarak doğrulama listesini alfabetik olarak sıralamaktadır.

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim S1 As Worksheet, Dizi As Object
    Dim Veri As Variant, Son As Long, X As Byte
   
    Set S1 = Sheets("Kanepe Veriler")
    Set Dizi = VBA.CreateObject("System.Collections.ArrayList")
       
    Son = S1.Cells(S1.Rows.Count, "B").End(xlUp).Row

    If Intersect(Target, Range("D2:E" & Rows.Count)) Is Nothing Then GoTo 10
    If Target.Count > 1 Then GoTo 10
    If Application.CutCopyMode = xlCopy Or Application.CutCopyMode = xlCut Then GoTo 10
   
    With Cells(Target.Row, "E")
        .Validation.Delete
        Veri = S1.Range("B2:H" & Son).Value
        For X = LBound(Veri, 1) To UBound(Veri, 1)
            If Cells(.Row, "D") = Veri(X, 1) Then
                If Not Dizi.Contains(Veri(X, 4)) Then Dizi.Add Veri(X, 4)
            End If
        Next
        If Dizi.Count > 0 Then
            Dizi.Sort
            .Validation.Add Type:=xlValidateList, Formula1:=Join(Dizi.ToArray, ",")
        End If
       
        If Not Dizi.Contains(.Value) Then .ClearContents
    End With
   
10
    Set S1 = Nothing
    Set Dizi = Nothing
End Sub

 

[alicimri]

Korhan hoca cevap vermiş, benimki alternatif olsun.
Veri doğrulamaya almaya çalıştığınız listenin A sütununda olduğunu var sayıldı..
Veri doğrulama da G1 hücresine göre ayarlanacaksa.
Aşağıdaki kodu bir kere çalıştırıp, A sütunundaki listeyi silebilirsiniz.

Sub Makro1()
say = Cells(Cells.Rows.Count, "A").End(3).Row
For i = 1 To say
yaz = yaz & Range("A" & i).Value & ","
Next
    Range("G1").Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, Formula1:=yaz
    End With
End Sub

 

[emreeyy]

Merhaba,

Dosyanızda aradaki E sütunu sildikten sonra aşağıdaki kodu sayfanızın kod bölümüne uygulayıp deneyiniz.

Kod ek olarak doğrulama listesini alfabetik olarak sıralamaktadır.

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim S1 As Worksheet, Dizi As Object
    Dim Veri As Variant, Son As Long, X As Byte
   
    Set S1 = Sheets("Kanepe Veriler")
    Set Dizi = VBA.CreateObject("System.Collections.ArrayList")
       
    Son = S1.Cells(S1.Rows.Count, "B").End(xlUp).Row

    If Intersect(Target, Range("D2:E" & Son)) Is Nothing Then GoTo 10
    If Target.Count > 1 Then GoTo 10
    If Application.CutCopyMode = xlCopy Or Application.CutCopyMode = xlCut Then GoTo 10
   
    With Cells(Target.Row, "E")
        .Validation.Delete
        Veri = S1.Range("B2:H" & Son).Value
        For X = LBound(Veri, 1) To UBound(Veri, 1)
            If Cells(.Row, "D") = Veri(X, 1) Then
                If Not Dizi.Contains(Veri(X, 4)) Then Dizi.Add Veri(X, 4)
            End If
        Next
        If Dizi.Count > 0 Then
            Dizi.Sort
            .Validation.Add Type:=xlValidateList, Formula1:=Join(Dizi.ToArray, ",")
        End If
       
        If Not Dizi.Contains(.Value) Then .ClearContents
    End With
   
10
    Set S1 = Nothing
    Set Dizi = Nothing
End Sub

Hocam herhangi bir yere tıkladığımda bu şekilde bir hata alıyorum
Debug dediğimde ise aşağıdaki kod sarı gözüküyor.
Acaba referanceden birşeyler mi seçmek gerekli?
Set Dizi = VBA.CreateObject("System.Collections.ArrayList")

Kodu Sayfa1 (Kanepe Giriş) e ekliyorum.

 

[emreeyy]

Hocam herhangi bir yere tıkladığımda bu şekilde bir hata alıyorum
Debug dediğimde ise aşağıdaki kod sarı gözüküyor.
Acaba referanceden birşeyler mi seçmek gerekli?
Set Dizi = VBA.CreateObject("System.Collections.ArrayList")

Kodu Sayfa1 (Kanepe Giriş) e ekliyorum.

Hocam .net framework 3.5 olması gerekiyormuş onun üstünde bu hatayı veriyormuş CreateObject
3.5 kurulumu yaptım şuan çalışıyor.

 

[Korhan Ayhan]

Sisteminizde yüklüdür diye düşünerek belirtmemiştim... Siz zaten olayı çözmüşsünüz. Tebrikler..

 

[emreeyy]

Sisteminizde yüklüdür diye düşünerek belirtmemiştim... Siz zaten olayı çzömüşsünüz. Tebrikler..

Hocam tekrar rahatsız edicem fakat şimdi şöyle birşey oldu.
Kanepe Veriler sayfamdaki "B" sütunundaki veriler 159.satırda bitiyor.
Kanepe Giriş sayfamda 159. u satıra kadar düzgünce çalıştı açılır hücre
fakat 159.u satırdandan sonra çalışmıyor.
Bu bir tesadüf müdür yoksa kanepe veriler sayfasında ne kadar satır varsa oraya kadar mı çalışıyor?

Bir de kanepe giriş "d" sütununda seçim yaptığımda "e" sütununa bazen açılır liste geliyor bazen gelmiyor. Gelmediğinde ctrl + s ile kaydettiğimde geliyor.Bunu neden yapıyor acaba?

 

[Korhan Ayhan]

Doğrulama listesinin oluşması için D sütununun dolu olması gerekiyor. Yani ilk seçiminize göre E sütunundaki doğrulama listesi oluşuyor.

 

[emreeyy]

Doğrulama listesinin oluşması için D sütununun dolu olması gerekiyor. Yani ilk seçiminize göre E sütunundaki doğrulama listesi oluşuyor.

Hocam orası dolu fakat ben şunu kastediyorum.

Set S1 = Sheets("Kanepe Veriler")
Set Dizi = VBA.CreateObject("System.Collections.ArrayList")

Son = S1.Cells(S1.Rows.Count, "B").End(xlUp).Row

If Intersect(Target, Range("D2:E" & Son)) Is Nothing Then GoTo 10

yukarıdaki kod yapısında

S1.Cells(S1.Rows.Count, "B").End(xlUp).Row ifadesi B sütununun sona kadar olan satır sayısını alıyor galiba.
daha sonra Range("D2:E" & Son) ifadesiyle bunu kullanıyoruz.

Son = S1.Cells(S1.Rows.Count, "B").End(xlUp).Row '159 satır
olduğundan

Kanepe Giriş Sayfasında açılır liste 159. u satıra kadar çalışıyor daha sonra çalışmıyor.

Özelden size dosyayı yolladım bakabilirseniz sevinirim.

 

[Korhan Ayhan]

Haklısınız. Orada kafam iyice dağılmış..

Üstte paylaştığım kodu revize ettim. Tekrar deneyiniz.

 

[emreeyy]

Haklısınız. Orada kafam iyice dağılmış..

Üstte paylaştığım kodu revize ettim. Tekrar deneyiniz.

Çok yordum sizi hakkınızı helal edin.
Çok teşekkür ederim.