• DİKKAT

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

Şartlı veri doğrulama

M

Mehmet Sait

Altın Üye
Katılım
19 Ekim 2009
Mesajlar
840
Excel Vers. ve Dili
Office 2016 TR
Merhaba,

Bir hücrede bulunan metne göre şartlı doğrulma nasıl yapılır?

Yardımlarınız için teşekkür ederim
 
Şu konuyu inceleyin:

şartlı veri doğrulama

merhabalar, ekteki excelde masraf formu sayfasında D7 hücresinde şirket seçtiğimde D9 hücresinde de veri doğrulama listesinde sadece o şirketin projelerinin gelmesini istiyorum yardımcı olabilirmisiniz
www.excel.web.tr www.excel.web.tr

Fazlası için örnek dosya paylaşmanız uygun olur.
 
YUSUF44' Alıntı:
Şu konuyu inceleyin:

şartlı veri doğrulama

merhabalar, ekteki excelde masraf formu sayfasında D7 hücresinde şirket seçtiğimde D9 hücresinde de veri doğrulama listesinde sadece o şirketin projelerinin gelmesini istiyorum yardımcı olabilirmisiniz
www.excel.web.tr www.excel.web.tr

Fazlası için örnek dosya paylaşmanız uygun olur.
Genişletmek için tıkla ...

Merhaba, Örnek dosya ektedir.

Teşekkür ederim
 

Ekli dosyalar

Sayfa2'de veri doğrulama uygulanacak G8'den itibaren aşağı doğru hücreleri seçin
Veri doğrulama menüsünde Listeyi seçin ve alttaki formül çubuğuna aşağıdaki formülü yazın:

=KAYDIR(Hatlar!$C$8:$C$10;0;KAÇINCI(F8;Hatlar!$C$7:$F$7;0)-1;;)
 
YUSUF44' Alıntı:
Sayfa2'de veri doğrulama uygulanacak G8'den itibaren aşağı doğru hücreleri seçin
Veri doğrulama menüsünde Listeyi seçin ve alttaki formül çubuğuna aşağıdaki formülü yazın:

=KAYDIR(Hatlar!$C$8:$C$10;0;KAÇINCI(F8;Hatlar!$C$7:$F$7;0)-1;;)
Genişletmek için tıkla ...

Teşekkür ederim.
 
Aşağıdaki kodları Sayfa2'nin kod bölümüne (sayfa adına sağ tıklayıp Kod görüntüle deyince açılan sayfaya) yapıştırıp deneyin:

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [F8:F100]) Is Nothing Then Exit Sub
If Target = "" Then Target.Offset(0, 1) = ""
End Sub
 
YUSUF44' Alıntı:
Aşağıdaki kodları Sayfa2'nin kod bölümüne (sayfa adına sağ tıklayıp Kod görüntüle deyince açılan sayfaya) yapıştırıp deneyin:

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [F8:F100]) Is Nothing Then Exit Sub
If Target = "" Then Target.Offset(0, 1) = ""
End Sub
Genişletmek için tıkla ...

Hocam,

Sayfada başka kodlar var. Verdiğinizi kodların arasına ekledim ancak yapamadım. Veri doğrulamada verdiğiniz kodları hatlar yan yana değilde alt alta olunca nasıl düzenlemem gerekir? Hatlarda ki ürün sayıları eşit olmadığından boşluk oluşuyor.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim s1 As Worksheet, s2 As Worksheet, ay As String, ara As Range
Dim s As Long, c As Range, f As String, v As Long, sayfalar()
Dim i As Long, sn As Long, col As Long, kl As Range, fl As Long
sayfalar = Array("Bardak", "Sidel", "Ektam", "Smi", "Siapi", "Tisse", "Damacana")
Set s1 = Sheets("Günlük Rapor")
v = s1.Cells(Rows.Count, "C").End(3).Row + 1

'//verdiğiniz kodlar//////////////////////////////
If Intersect(Target, [C8:C100]) Is Nothing Then Exit Sub
If Target = "" Then Target.Offset(0, 1) = ""
'////////////////////////////////////

If Target.Address <> "$J$5" Then Exit Sub
If Target.Value = "" Then s1.Shapes.Range("Button 1").TextFrame.Characters.Text = "KAYDET": Exit Sub
If IsDate(Target.Value) = True Then
s1.Range("B8:G" & v) = ""
If Len(Year(Target.Value)) = 3 Then MsgBox "YIL hatalı": Exit Sub
ay = MonthName(Month(Target.Value), False)
fl = 0
For s = 0 To UBound(sayfalar)
Set s2 = Sheets(sayfalar(s))
'----------------------------------------------
'If s2.Name = "Damacana" Then
s2.Unprotect Password:="699"
'---------------------------------------------------
Set ara = s2.Rows("3:3").Find(ay, , xlFormulas, xlPart, , , False)
Set kl = s2.Range(s2.Cells(8, ara.Column), s2.Cells(Rows.Count, ara.Column + 2)).Find("Toplam", , xlFormulas, xlPart, xlByRows, xlNext, False, , False)
If kl Is Nothing Then
MsgBox s2.Name & " sayfasında TOPLAM satırı bulunamadı" & vbCrLf & "İşlem Yapılamadı"
GoTo 10
End If
If Not ara Is Nothing Then
With s2.Columns(ara.Column)
Set c = .Find(DateValue(Target.Value), , xlFormulas, , xlByRows, xlNext, False, False)
If Not c Is Nothing Then
f = c.Address
Do
v = s1.Cells(Rows.Count, "C").End(3).Row + 1
s1.Cells(v, "B") = s2.Cells(c.Row, c.Column)
s1.Cells(v, "C") = sayfalar(s)
s1.Cells(v, "D") = s2.Cells(c.Row, c.Column + 1)
s1.Cells(v, "E") = s2.Cells(c.Row, c.Column + 2)
s1.Cells(v, "F") = s2.Cells(c.Row, c.Column + 3)
i = 0
fl = 1
If sayfalar(s) = "Damacana" Then
s1.Cells(v, "G") = s2.Cells(c.Row, c.Column + 4)
s2.Cells(c.Row, c.Column + 4) = ""
i = 1
End If
col = c.Column
s2.Cells(c.Row, c.Column) = ""
s2.Cells(c.Row, c.Column + 1) = ""
s2.Cells(c.Row, c.Column + 2) = ""
s2.Cells(c.Row, c.Column + 3) = ""
Set c = .FindNext(c)
If c Is Nothing Then Exit Do
Loop While Not c Is Nothing And c.Address <> f

sn = s2.Cells(kl.Row, col).End(3).Row
s2.Range(s2.Cells(8, col), s2.Cells(sn, col + 3 + i)).Sort Key1:=s2.Cells(8, col), Order1:=xlAscending
'--------------------------------
'If s2.Name = "Damacana" Then
s2.Protect Password:="699"
'-------------------------------------------------------
End If
End With
End If
10:
Next
If fl = 0 Then MsgBox "Yazılan Tarih Bulunamadı": Exit Sub
If s1.Cells(Rows.Count, "C").End(3).Row > 7 Then
ActiveSheet.Shapes.Range("Button 1").TextFrame.Characters.Text = "GÜNCELLE"
End If
Else
ActiveSheet.Shapes.Range("Button 1").TextFrame.Characters.Text = "KAYDET"
MsgBox "tarih hatalı"
End If
Range("B8").Select
End Sub

Teşekkür ederim
 

Ekli dosyalar

Kod çakışmaması için sayfanızdaki kodu aşağıdakiyle değiştirin, iki kodu birleştirdim:

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim s1 As Worksheet, s2 As Worksheet, ay As String, ara As Range
Dim s As Long, c As Range, f As String, v As Long, sayfalar()
Dim i As Long, sn As Long, col As Long, kl As Range, fl As Long
sayfalar = Array("Bardak", "Sidel", "Ektam", "Smi", "Siapi", "Tisse", "Damacana")
Set s1 = Sheets("Günlük Rapor")
v = s1.Cells(Rows.Count, "C").End(3).Row + 1

'//verdiğiniz kodlar//////////////////////////////
If Intersect(Target, [C8:C100]) Is Nothing Then GoTo 30
If Target = "" Then Target.Offset(0, 1) = ""
'////////////////////////////////////

If Target.Address <> "$J$5" Then Exit Sub
If Target.Value = "" Then s1.Shapes.Range("Button 1").TextFrame.Characters.Text = "KAYDET": Exit Sub
If IsDate(Target.Value) = True Then
s1.Range("B8:G" & v) = ""
If Len(Year(Target.Value)) = 3 Then MsgBox "YIL hatalı": Exit Sub
ay = MonthName(Month(Target.Value), False)
fl = 0
For s = 0 To UBound(sayfalar)
Set s2 = Sheets(sayfalar(s))
'----------------------------------------------
'If s2.Name = "Damacana" Then
s2.Unprotect Password:="699"
'---------------------------------------------------
Set ara = s2.Rows("3:3").Find(ay, , xlFormulas, xlPart, , , False)
Set kl = s2.Range(s2.Cells(8, ara.Column), s2.Cells(Rows.Count, ara.Column + 2)).Find("Toplam", , xlFormulas, xlPart, xlByRows, xlNext, False, , False)
If kl Is Nothing Then
MsgBox s2.Name & " sayfasında TOPLAM satırı bulunamadı" & vbCrLf & "İşlem Yapılamadı"
GoTo 10
End If
If Not ara Is Nothing Then
With s2.Columns(ara.Column)
Set c = .Find(DateValue(Target.Value), , xlFormulas, , xlByRows, xlNext, False, False)
If Not c Is Nothing Then
f = c.Address
Do
v = s1.Cells(Rows.Count, "C").End(3).Row + 1
s1.Cells(v, "B") = s2.Cells(c.Row, c.Column)
s1.Cells(v, "C") = sayfalar(s)
s1.Cells(v, "D") = s2.Cells(c.Row, c.Column + 1)
s1.Cells(v, "E") = s2.Cells(c.Row, c.Column + 2)
s1.Cells(v, "F") = s2.Cells(c.Row, c.Column + 3)
i = 0
fl = 1
If sayfalar(s) = "Damacana" Then
s1.Cells(v, "G") = s2.Cells(c.Row, c.Column + 4)
s2.Cells(c.Row, c.Column + 4) = ""
i = 1
End If
col = c.Column
s2.Cells(c.Row, c.Column) = ""
s2.Cells(c.Row, c.Column + 1) = ""
s2.Cells(c.Row, c.Column + 2) = ""
s2.Cells(c.Row, c.Column + 3) = ""
Set c = .FindNext(c)
If c Is Nothing Then Exit Do
Loop While Not c Is Nothing And c.Address <> f

sn = s2.Cells(kl.Row, col).End(3).Row
s2.Range(s2.Cells(8, col), s2.Cells(sn, col + 3 + i)).Sort Key1:=s2.Cells(8, col), Order1:=xlAscending
'--------------------------------
'If s2.Name = "Damacana" Then
s2.Protect Password:="699"
'-------------------------------------------------------
End If
End With
End If
10:
Next
If fl = 0 Then MsgBox "Yazılan Tarih Bulunamadı": Exit Sub
If s1.Cells(Rows.Count, "C").End(3).Row > 7 Then
ActiveSheet.Shapes.Range("Button 1").TextFrame.Characters.Text = "GÜNCELLE"
End If
Else
ActiveSheet.Shapes.Range("Button 1").TextFrame.Characters.Text = "KAYDET"
MsgBox "tarih hatalı"
End If
Range("B8").Select
30:
If Intersect(Target, [F8:F100]) Is Nothing Then Exit Sub
If Target = "" Then Target.Offset(0, 1) = ""
End Sub

Diğer isteğinizi bilemedim maalesef.
 
YUSUF44' Alıntı:
Kod çakışmaması için sayfanızdaki kodu aşağıdakiyle değiştirin, iki kodu birleştirdim:

PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim s1 As Worksheet, s2 As Worksheet, ay As String, ara As Range
Dim s As Long, c As Range, f As String, v As Long, sayfalar()
Dim i As Long, sn As Long, col As Long, kl As Range, fl As Long
sayfalar = Array("Bardak", "Sidel", "Ektam", "Smi", "Siapi", "Tisse", "Damacana")
Set s1 = Sheets("Günlük Rapor")
v = s1.Cells(Rows.Count, "C").End(3).Row + 1

'//verdiğiniz kodlar//////////////////////////////
If Intersect(Target, [C8:C100]) Is Nothing Then GoTo 30
If Target = "" Then Target.Offset(0, 1) = ""
'////////////////////////////////////

If Target.Address <> "$J$5" Then Exit Sub
If Target.Value = "" Then s1.Shapes.Range("Button 1").TextFrame.Characters.Text = "KAYDET": Exit Sub
If IsDate(Target.Value) = True Then
s1.Range("B8:G" & v) = ""
If Len(Year(Target.Value)) = 3 Then MsgBox "YIL hatalı": Exit Sub
ay = MonthName(Month(Target.Value), False)
fl = 0
For s = 0 To UBound(sayfalar)
Set s2 = Sheets(sayfalar(s))
'----------------------------------------------
'If s2.Name = "Damacana" Then
s2.Unprotect Password:="699"
'---------------------------------------------------
Set ara = s2.Rows("3:3").Find(ay, , xlFormulas, xlPart, , , False)
Set kl = s2.Range(s2.Cells(8, ara.Column), s2.Cells(Rows.Count, ara.Column + 2)).Find("Toplam", , xlFormulas, xlPart, xlByRows, xlNext, False, , False)
If kl Is Nothing Then
MsgBox s2.Name & " sayfasında TOPLAM satırı bulunamadı" & vbCrLf & "İşlem Yapılamadı"
GoTo 10
End If
If Not ara Is Nothing Then
With s2.Columns(ara.Column)
Set c = .Find(DateValue(Target.Value), , xlFormulas, , xlByRows, xlNext, False, False)
If Not c Is Nothing Then
f = c.Address
Do
v = s1.Cells(Rows.Count, "C").End(3).Row + 1
s1.Cells(v, "B") = s2.Cells(c.Row, c.Column)
s1.Cells(v, "C") = sayfalar(s)
s1.Cells(v, "D") = s2.Cells(c.Row, c.Column + 1)
s1.Cells(v, "E") = s2.Cells(c.Row, c.Column + 2)
s1.Cells(v, "F") = s2.Cells(c.Row, c.Column + 3)
i = 0
fl = 1
If sayfalar(s) = "Damacana" Then
s1.Cells(v, "G") = s2.Cells(c.Row, c.Column + 4)
s2.Cells(c.Row, c.Column + 4) = ""
i = 1
End If
col = c.Column
s2.Cells(c.Row, c.Column) = ""
s2.Cells(c.Row, c.Column + 1) = ""
s2.Cells(c.Row, c.Column + 2) = ""
s2.Cells(c.Row, c.Column + 3) = ""
Set c = .FindNext(c)
If c Is Nothing Then Exit Do
Loop While Not c Is Nothing And c.Address <> f

sn = s2.Cells(kl.Row, col).End(3).Row
s2.Range(s2.Cells(8, col), s2.Cells(sn, col + 3 + i)).Sort Key1:=s2.Cells(8, col), Order1:=xlAscending
'--------------------------------
'If s2.Name = "Damacana" Then
s2.Protect Password:="699"
'-------------------------------------------------------
End If
End With
End If
10:
Next
If fl = 0 Then MsgBox "Yazılan Tarih Bulunamadı": Exit Sub
If s1.Cells(Rows.Count, "C").End(3).Row > 7 Then
ActiveSheet.Shapes.Range("Button 1").TextFrame.Characters.Text = "GÜNCELLE"
End If
Else
ActiveSheet.Shapes.Range("Button 1").TextFrame.Characters.Text = "KAYDET"
MsgBox "tarih hatalı"
End If
Range("B8").Select
30:
If Intersect(Target, [F8:F100]) Is Nothing Then Exit Sub
If Target = "" Then Target.Offset(0, 1) = ""
End Sub

Diğer isteğinizi bilemedim maalesef.
Genişletmek için tıkla ...

Teşekkür ederim.
 
Yataya göre değişen veri doğrulama için veri doğrulama formülünü aşağıdakiyle değiştirin. Değiştirirken Hücre aralığı ve sonraki 20'yi olabilecek en çok ürününüze göre değiştirin:

=KAYDIR(Hatlar!$D$6:$W$6;KAÇINCI(F8;Hatlar!$C$7:$C$10;0);0;1;20)
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst