• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Soru Veri doğrulamaya hücredeki veriyi ekleme

  • Konbuyu başlatan Konbuyu başlatan emreeyy
  • Başlangıç tarihi Başlangıç tarihi
E

emreeyy

Katılım
20 Mayıs 2016
Mesajlar
86
Excel Vers. ve Dili
2010
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?



Ads-z.png
 
Merhaba,

Sayfanın kod bölümüne kopyalayın.
Kod: 
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
 
Ömer' Alıntı:
Merhaba,

Sayfanın kod bölümüne kopyalayın.
Kod: 
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
Genişletmek için tıkla ...


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.

Kod: 
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
 
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.
 
Ö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
 
Bu durumda F sütunu silinecek sanırım..
 
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.

C++: 
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
 
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.
Kod: 
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
 
Korhan Ayhan' Alıntı:
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.

C++: 
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
Genişletmek için tıkla ...

Ads-z.png


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' Alıntı:
Ads-z.png


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.
Genişletmek için tıkla ...


Hocam .net framework 3.5 olması gerekiyormuş onun üstünde bu hatayı veriyormuş CreateObject
3.5 kurulumu yaptım şuan çalışıyor.
 
Sisteminizde yüklüdür diye düşünerek belirtmemiştim... Siz zaten olayı çözmüşsünüz. Tebrikler..
 
Korhan Ayhan' Alıntı:
Sisteminizde yüklüdür diye düşünerek belirtmemiştim... Siz zaten olayı çzömüşsünüz. Tebrikler..
Genişletmek için tıkla ...

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?
 
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.
 
Korhan Ayhan' Alıntı:
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.
Genişletmek için tıkla ...

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.
 
Haklısınız. Orada kafam iyice dağılmış..

Üstte paylaştığım kodu revize ettim. Tekrar deneyiniz.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst