çok sütunlu veri doğrulama

[bunyaming]

Merhaba,

değerli uzman arkadaşlarım

yapmak istediğim fakat uyarlayamadığım bir konu var.

Gelişmiş filtre tabanlı yapmaya çalıştığım bir programda belli hücrelere veri doğrulama atadım. Aşağıda ki kod ile bir sütunda ki değerleri benzersiz olarak veri doğrulama içine getiriyor.
Örneğin bu aralığı kendi tanımlayacağım şekilde aynı anda a,c,d,e,f vs sütünlara uygulamam gerekirse nasıl düzenlemeliyim.
aynı anda c sütununda ki verileri b4 hücresine veri doğrulama ile tanımlayacak
e sütununda ki verileri b5 hücresine tanımlayacak gibi
ben bunu bu şekilde devam ettireceğim
yardımcı olabilirseniz sevinirim

Sub veridoğrulama()
Dim i%, c&, say%, arr()
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If WorksheetFunction.CountIf(Range("C1:C" & i), Cells(i, "C")) = 1 Then
say = say + 1
ReDim Preserve arr(1 To say)
For c = 1 To UBound(arr)
arr(say) = Cells(i, "C").Value
Next c
End If
Next i
Range("B4").Validation.Delete
Range("B4").Validation.Add Type:=xlValidateList, Formula1:=Join(arr, ",")

End Sub

 

[bunyaming]

Tekrar Merhaba,

Bu kodlama veya kodu düzenleme hakkında mutlaka Uzman bir arkadaşın bilgisi vardır diye düşünüyorum.

Yardımcı olabilirmisiniz lütfen

Teşekkürler

 

[PLİNT]

Merhaba
Aşağıdaki gibi denermisiniz?
Kırmızı (6) "F" sütunu dahil, mavi ile bölüm ile "B" sütunu atlanacak
(2. satırların hepsinde dolu olduğu varsayılarak)

[SIZE="2"]Sub veridoğrulama()
Dim i%, c&, say%, arr()
Dim x As Long, rw As Long
Dim j As Integer
For x = 1 To [COLOR="Red"]6[/COLOR]
If Cells(2, x) <> "" Then
[COLOR="Blue"]If x = 2 Then x = x + 1[/COLOR]
rw = Cells(Rows.Count, x).End(xlUp).Row
For i = 2 To rw
If WorksheetFunction.CountIf(Range(Cells(1, x), Cells(i, x)), Cells(i, x)) = 1 Then
say = say + 1
ReDim Preserve arr(1 To say)
For c = 1 To UBound(arr)
arr(say) = Cells(i, x).Value
Next c: End If: Next i
j = j + 1
Range("B" & 3 + j).Validation.Delete
Range("B" & 3 + j).Validation.Add Type:=xlValidateList, Formula1:=Join(arr, ",")
Erase arr: say = 0
End If: Next
End Sub[/SIZE]

 

[bunyaming]

Cevap verdiğiniz için Teşekkürler Sayın Plint

Yalnız şu şekilde bir problem oldu

o sütunlardaki benzersizlerin tamamını b4 hücresi içinde ki veri doğrulamada gösterdi.

Olmasını rica ettiğim ise örneğin e sütununda ki verilerin b5 hücresinde veri doğrulama ile benzersizlerinin listelenmesi.
h sütununda ki verilerin b6 hücresinde veri doğrulama ile benzersiz listelenmesi gibi uzayacak.
Bunu istememin sebebi veri doğrulama ile seçtikçe makro otomatik tetikliyor ve filtre uygulandığı için bir alttaki seçenekte, aranacak data daralıyor bu bu şekilde eriyerek dinamik olarak güncelleniyor.
Bunu makro kaydet benzersizleri kaldır ve veri doğrulama içinde kaydır ve bağ değ dolu say ile çözmeye çalıştım fakat hem çok ağır çalıştı hemde verilerde ne kadar düzeltmeye çalışsamda bir ço hücre kayma oluyor

Talep ettiğim kodun nasıl revize edilmesi gerektiğini öğretirseniz veya yolu gösterirseniz çok minnettar kalırım.

Bir çok kitap kurcaladım burada da bir çok çözülmüş soru üzerinden uyarlamaya çalıştım fakat bir türlü yapamadım

Teşekkürler

 

[bunyaming]

Dosyayı da ekledim Sayın Plint

aşağıda ki filtrelenmiş verileri göre uyarlamaya açlışıyorum.

Teşekkürler

 

[PLİNT]

Örnek dosyanızı burayada ekleyip indirme adresi verirmisiniz, yukarıdaki dosyayı indirme yetkim yok
Filtre sütunlar içinde aşağıdaki gibi yapabiliriz, olmazsa dosyayıda ilgili adrese eklersiniz
(filtrelendikten sonra ilgili sütunun ikinci satırdan itibaren boş kalmayacağı varsayılarak)

http://s7.dosya.tc/server2/fvcx9w/veri.zip.html

[SIZE="2"]Sub veridoğrulama()
Dim i%, c&, say%, arr()
Dim x As Long, rw As Long
Dim j As Integer
Dim s, veri As Range
For x = 1 To 6
If x = 2 Then x = x + 1
Set veri = Columns(x).SpecialCells(xlCellTypeVisible).Cells.SpecialCells(xlCellTypeConstants, 23).Cells
For Each s In veri
If s.Row <> 1 Then
If WorksheetFunction.CountIf(Range(Cells(1, x), Cells(s.Row, x)), s.Value) = 1 Then
say = say + 1
ReDim Preserve arr(1 To say)
For c = 1 To UBound(arr)
arr(say) = s.Value
Next c: End If: End If: Next s
j = j + 1
Range("B" & 3 + j).Validation.Delete
Range("B" & 3 + j).Validation.Add Type:=xlValidateList, Formula1:=Join(arr, ",")
Erase arr: say = 0:
 Next
End Sub[/SIZE]

 

[bunyaming]

İlgili adrese yükledim dosyayı

teşekkürler

http://s7.dosya.tc/server2/uzcbqr/ACIK_-_Kopya2.rar.html

 

[PLİNT]

Merhaba

Ek dosyayı deneyin eklenen kodlar "Filtre" sayfasının, kod penceresinde
"B4:B14" aralığında hücre seçildiğinde duruma göre kendini yenilecektir
İlgili aralıkta seçili veri yoksa "Sayfa1" den, varsa "Filtre" sayfasından veri doğrulama değerleri eklenecek
http://s7.dosya.tc/server2/ajmhfe/ACIK_-_Kopya3.zip.html

 

[bunyaming]

Teşekkürler Sayın Plint

mükemmel olmuş yazdığınız kodları inceleyip arşivim de mutlaka bulunduracağım.

Desteğiniz ve katkılarınız için minnettarım

iyi akşamlar

 

[PLİNT]

Teşekkürler Sayın Plint

mükemmel olmuş yazdığınız kodları inceleyip arşivim de mutlaka bulunduracağım.

Desteğiniz ve katkılarınız için minnettarım
iyi akşamlar

Rica ederim. Güle güle kullanın.
İsteğiniz şeklin tam olarak nasıl olduğu konusunda biraz kararsız kaldım ama böyle bir sonucun dosyanıza uygun olacağını düşündüm, eğer "Sayfa1" de dolu satır sayısı çok olmayacaksa bu şekilde yeterli olacaktır, olmazsa değişiklik/ek yaparız.
İşlerinizde kolaylıklar dilerim.

 

[bunyaming]

Tekrar Merhaba Sayın Plint

sizin attığınız dosya çalışıyor problem yok yalnız
yaptığınız dosyaya sayfa1 kısmına ado ile kendi yüklü datalarımı aldım 49 bin satır
run time error 6 hatası veriyor
aşağıda ki satırı sarı ile renklendiriyor
bir yerde yanlışmı yapıyorum
hiç bir değişiklik yapmadan sadece veri boyutunu arttırdım.
sütun vs hepsi aynı

"For i = j To rw"

saygılarımla

 

[bunyaming]

Tekrar Tekrar Zahmet vermemek için belirtmeliyim ki
Sayfa1 de veriler yaklaşık 100 bin satır olacak
Data Yıllık hem bir veri tabanı hemde bu veri tabanında dinamik sorgulamalar yapmak, anlık cevaplar verebilmek için özellikle bu şekilde bir format üzerinde duruyorum.Tabi bu sorgulamayı personelde kullanacağı için hem işini yapıp sorgulanmadan kendi kendini takip edip performanslarını ölçebilecekler.

Bu problemde de bana yardımcı olursanız gerçekten beni çok büyük bir problemden kurtarmış olacaksınız

Teşekkürler

 

[PLİNT]

"Worksheet_SelectionChange" altındaki kodlar "scripting.dictionary" kullanarak
değişti daha hızlı olacaktır.
Yavaşlama (yüzbin satırda) "FİLTRE" makronuzdan olacaktır; deneyin gerekirse onlarıda değişiriz

[SIZE="2"]Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B4:B14]) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Call FİLTRE
'Call veridoğrulayeni
Application.ScreenUpdating = True
'Target.Activate   '[COLOR="Blue"]BU SATIR pasif[/COLOR]
End Sub



Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("B4:B10,B12:B14")) Is Nothing Then Exit Sub
Dim liste(), s1 As Worksheet, gh As String, j As Integer
Dim sutun(), satır As Variant, sut As String: [COLOR="Blue"]Dim i as long[/COLOR]
Dim x As Long, rw As Long: Dim dc As Object
Set dc = CreateObject("Scripting.Dictionary")
dc.CompareMode = vbTextCompare
Set s1 = Sheets("FİLTRE"): gh = "L": j = 26
If WorksheetFunction.CountA(Range("B4:B10,B12:B14")) = 0 Or _
s1.Cells(Rows.Count, "A").End(xlUp).Row = 25 Then
Set s1 = Sheets("Sayfa1")
gh = "E": j = 2
End If
sutun = Array("C", gh, "G", "H", "K", "D", "M", "B", "A", "AF")
satır = Array("4", "5", "6", "7", "8", "9", "10", "12", "13", "14")
For x = 0 To UBound(satır)
If Target.Row = satır(x) Then sut = sutun(x)
Next
rw = s1.Cells(Rows.Count, sut).End(xlUp).Row
If j = rw Then
Target.Validation.Delete
Target.Validation.Add Type:=xlValidateList, Formula1:=s1.Range(sut & j)
Exit Sub
Else
liste = s1.Range(sut & j & ":" & sut & rw)
End If
For i = 1 To UBound(liste)
If Not dc.exists(liste(i, 1)) And liste(i, 1) <> "" Then dc.Add liste(i, 1), ""
Next
Target.Validation.Delete
Target.Validation.Add Type:=xlValidateList, Formula1:=Join(dc.keys, ",")
End Sub
[/SIZE]

 

[bunyaming]

Merhaba Sayın Plint

bu seferde aynı şekilde run time error 6 hatası verdi ve sarı olarak renklendirdiği kısım

"For i = 1 To UBound(liste)"

saygılarımla

 

[PLİNT]

Merhaba Sayın Plint

bu seferde aynı şekilde run time error 6 hatası verdi ve sarı olarak renklendirdiği kısım
"For i = 1 To UBound(liste)"
saygılarımla

Merhaba
"i" tanımlamasını "long" olarak değişelim önceki gibi kalmış
(Önceki mesajımda düzelttim)

[SIZE="2"]Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("B4:B10,B12:B14")) Is Nothing Then Exit Sub
Dim liste(), s1 As Worksheet, gh As String, j As Integer
Dim sutun(), satır As Variant, sut As String: [COLOR="Red"]Dim i as long[/COLOR][/SIZE]

 

[bunyaming]

Sayın Plint

ne desem ne kadar teşekkür etsem az kalacak biliyorum

Allah Razı olsun diyeyim

elinize,emeğinize sağlık

kusursuz çalışıyor

iyi geceler

 

[PLİNT]

Sayın Plint
ne desem ne kadar teşekkür etsem az kalacak biliyorum
Allah Razı olsun diyeyim
elinize,emeğinize sağlık
kusursuz çalışıyor
iyi geceler

Rica ederim, sağolun, sorun çıkarsa bildirirsiniz. Hayırlı geceler.

 

[bunyaming]

Sayın Plint

ilk problem oluştu

direkt olarak b5 hücresinde veri doğrulama çıkmıyor fakat
mesela b4 ü seçip daha sonra b5 e inildiğinde veya b7 den sonra b5 e çıkıldığında problem yok
Bunu düzeltmek fazla zamanınızı almaz ise tekrar bir yardımcı olma şansınız varmı acaba? Her hangi birini aktif etmeden b5 aktif olmuyor ve direkt olarak mesela b4 dekini silip b5 e tıklandığında aşağıdaki gibi bir uyarı veriyor

"run time error 1004"

kod kısmında ise

"Target.Validation.Add Type:=xlValidateList, Formula1:=Join(dc.keys, ",")"

düzeltilebilirmi veya bu şekildemi kullanmalıyım?

teşekkürler

 

[bunyaming]

Sayın Plint

kendi kendine düzelti sanırım makina soğuktu

şuan problemsiz çalışıyor

Teşekkürler

 

[PLİNT]

Sayın Plint

ilk problem oluştu

direkt olarak b5 hücresinde veri doğrulama çıkmıyor fakat
mesela b4 ü seçip daha sonra b5 e inildiğinde veya b7 den sonra b5 e çıkıldığında problem yok
Bunu düzeltmek fazla zamanınızı almaz ise tekrar bir yardımcı olma şansınız varmı acaba? Her hangi birini aktif etmeden b5 aktif olmuyor ve direkt olarak mesela b4 dekini silip b5 e tıklandığında aşağıdaki gibi bir uyarı veriyor

"Modül 1" e aşağıdaki kodları ekleyip kaydedin kapanışta,ve açılışta "veri doğrulamaları" silsin

[SIZE="2"]Sub auto_close()
With Sheets("FİLTRE")
.Activate
.[A1].Select
.Range("B4:B10,B12:B14").Value = ""
.Range("B4:B10,B12:B14").Validation.Delete
End With
End Sub
Sub auto_open()
With Sheets("FİLTRE")
.Activate
.[A1].Select
.Range("B4:B10,B12:B14").Value = ""
.Range("B4:B10,B12:B14").Validation.Delete
End With
End Sub[/SIZE]