Veri doğrulama ve düşeyara yı vba ile yapma ?

[sratacc]

Arkadaşlar selamlar saygılar.
Mevcutta veridoğrulama ve düşeyara ile yaptığım sistemi ana dosyamda kullanamadığımdan(fonksiyonlar ve koşullu biçimlendirme iptal durumda) vba yardımı ile (listwiev vs nasıl olacağını bilmiyorum ) oluşturmak istiyorum.
Dosya içeriğinde gerekli font, ilk ve ikinci dosyalar bulunmaktadır.
teşekkürler

 

[numan şamil]

Arkadaşlar selamlar saygılar.
Mevcutta veridoğrulama ve düşeyara ile yaptığım sistemi ana dosyamda kullanamadığımdan(fonksiyonlar ve koşullu biçimlendirme iptal durumda) vba yardımı ile (listwiev vs nasıl olacağını bilmiyorum ) oluşturmak istiyorum.
Dosya içeriğinde gerekli font, ilk ve ikinci dosyalar bulunmaktadır.
teşekkürler

Merhaba
=Düşeyara(E2;H:I,2,0) için

Sub işlemyap1()
On Error Resume Next
Application.ScreenUpdating = False
For i = 2 To 600
If Range("e" & i).Value > "" Then Range("f" & i).Value = WorksheetFunction.VLookup(Range("e" & i), Range("H2:I600"), 2, 0)
Next
Application.ScreenUpdating = True
End Sub
'************
'Hücre boyama için
Sub boya()
On Error Resume Next
Application.ScreenUpdating = False
Range("I3:I600").Interior.ColorIndex = xlNone
For i = 2 To 600
If Range("h" & i).Value = "ALİ" Then Range("ı" & i).Interior.ColorIndex = 6
Next
Application.ScreenUpdating = True
End Sub
'***********
Kendinize uyarlayın
Rakam veya yazı rengi için
Interior.ColorIndex = 6
yerine
Font.ColorIndex = 6
Yazın
Bazı renk kodları
' .Interior.ColorIndex = 3 'kırmızı
'.Interior.ColorIndex = 1 'siyah
' .Interior.ColorIndex = 4 'yeşil
' .ColorIndex = 5 'koyu mavi
.ColorIndex = 6 'sarı
'.Interior.ColorIndex = 7 'pembe
'.Interior.ColorIndex = 8 'açık mavi
'n.Interior.ColorIndex = 9 ' kahve

 

[sratacc]

Merhaba
=Düşeyara(E2;H:I,2,0) için

Sub işlemyap1()
On Error Resume Next
Application.ScreenUpdating = False
For i = 2 To 600
If Range("e" & i).Value > "" Then Range("f" & i).Value = WorksheetFunction.VLookup(Range("e" & i), Range("H2:I600"), 2, 0)
Next
Application.ScreenUpdating = True
End Sub
'************
'Hücre boyama için
Sub boya()
On Error Resume Next
Application.ScreenUpdating = False
Range("I3:I600").Interior.ColorIndex = xlNone
For i = 2 To 600
If Range("h" & i).Value = "ALİ" Then Range("ı" & i).Interior.ColorIndex = 6
Next
Application.ScreenUpdating = True
End Sub
'***********
Kendinize uyarlayın
Rakam veya yazı rengi için
Interior.ColorIndex = 6
yerine
Font.ColorIndex = 6
Yazın
Bazı renk kodları
' .Interior.ColorIndex = 3 'kırmızı
'.Interior.ColorIndex = 1 'siyah
' .Interior.ColorIndex = 4 'yeşil
' .ColorIndex = 5 'koyu mavi
.ColorIndex = 6 'sarı
'.Interior.ColorIndex = 7 'pembe
'.Interior.ColorIndex = 8 'açık mavi
'n.Interior.ColorIndex = 9 ' kahve

hocam dosyaya eklerseniz sevinirim, çalıştıramadım çünkü

 

[numan şamil]

Merhaba Kodları;
Dosyanızı versiyon farkından dolayı değişiklikleri kaydedemiyorum

Ancak 1 nolu mesajınızdaki
Ekli Dosyanızın F sutunundaki düşeyara formülü için
Boş modüle yazıp bir butona atayarak dosya2 de denermisiniz

Sub işlemyap1()
On Error Resume Next
Application.ScreenUpdating = False
For i = 2 To 600
If Range("e" & i).Value > "" Then Range("f" & i).Value = WorksheetFunction.VLookup(Range("e" & i), Range("H2:I600"), 2, 0)
Next
Application.ScreenUpdating = True
End Sub
' Not: Diğer yazı ve hücre renkleri ile ilgili kodlar bilgi amaçlı verilmiştir

 

[sratacc]

Merhaba Kodları;
Dosyanızı versiyon farkından dolayı değişiklikleri kaydedemiyorum

Ancak 1 nolu mesajınızdaki
Ekli Dosyanızın F sutunundaki düşeyara formülü için
Boş modüle yazıp bir butona atayarak dosya2 de denermisiniz

Sub işlemyap1()
On Error Resume Next
Application.ScreenUpdating = False
For i = 2 To 600
If Range("e" & i).Value > "" Then Range("f" & i).Value = WorksheetFunction.VLookup(Range("e" & i), Range("H2:I600"), 2, 0)
Next
Application.ScreenUpdating = True
End Sub
' Not: Diğer yazı ve hücre renkleri ile ilgili kodlar bilgi amaçlı verilmiştir

hocam çalıştı ancak dosya içeriğinde de anlatmaya çalıştığım gibi butona atamak yerine senkronize şekilde çalışması mümkün değilmi. yani ben işlem yapılmadı verisini seçtiğimde otomatik ünlem x işaretini yanına getiremez mi ?

teşekkürler

 

[numan şamil]

hocam çalıştı ancak dosya içeriğinde de anlatmaya çalıştığım gibi butona atamak yerine senkronize şekilde çalışması mümkün değilmi. yani ben işlem yapılmadı verisini seçtiğimde otomatik ünlem x işaretini yanına getiremez mi ?

teşekkürler

Merhaba
Diğer kodlar modül de kalsın
Sayfanın kod bölümüne
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Son
If Intersect(Target, [E2:E600]) Is Nothing Then Exit Sub
Call işlemyap1
Son:
End Sub
Yazıp denermisiniz
Not: modüldeki kodlarda
For i = 2 To 600
Kısmını 600 veri olan en son satır sayısını yazabilirsiniz

 

[sratacc]

Merhaba
Diğer kodlar modül de kalsın
Sayfanın kod bölümüne
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Son
If Intersect(Target, [E2:E600]) Is Nothing Then Exit Sub
Call işlemyap1
Son:
End Sub
Yazıp denermisiniz
Not: modüldeki kodlarda
For i = 2 To 600
Kısmını 600 veri olan en son satır sayısını yazabilirsiniz

Hocam siz 2. dosyaya göre kod vermissiniz ancak ben ''yapılmak istenen'' dediğim dosya için bunu yapmak istiyordum sizin kodları buna uyarladım ve gayet güzel çalışıyor. ancak renklendirme işini beceremedim son kısımda yine sizin verdiğiniz kodu uyarladım ancak renklendirme olmadı.


Sayfanın kod bölümüne

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Son
If Intersect(Target, [H2:H6600]) Is Nothing Then Exit Sub
Call işlemyap1
Son:
End Sub




BOŞ BİR MODÜLE

Sub işlemyap1()
On Error Resume Next
Application.ScreenUpdating = False
For o = 5 To 6600
If Range("H" & O).Value > "" Then Range("I" & O).Value = WorksheetFunction.VLookup(Range("H" & O), Range("N2:O666600"), 2, 0)
Next
Application.ScreenUpdating = True
End Sub



Sub boya()
On Error Resume Next
Application.ScreenUpdating = False
Range("O5:O6600").Font.ColorIndex = xlNone
For i = 5 To 6600
If Range("N" & O).Value = "ALİ" Then Range("O" & O).Font.ColorIndex = 3
Next
Application.ScreenUpdating = True
End Sub

 

[numan şamil]

Hocam siz 2. dosyaya göre kod vermissiniz ancak ben ''yapılmak istenen'' dediğim dosya için bunu yapmak istiyordum sizin kodları buna uyarladım ve gayet güzel çalışıyor. ancak renklendirme işini beceremedim son kısımda yine sizin verdiğiniz kodu uyarladım ancak renklendirme olmadı.


Sayfanın kod bölümüne

Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Son
If Intersect(Target, [H2:H6600]) Is Nothing Then Exit Sub
Call işlemyap1
Son:
End Sub




BOŞ BİR MODÜLE

Sub işlemyap1()
On Error Resume Next
Application.ScreenUpdating = False
For o = 5 To 6600
If Range("H" & O).Value > "" Then Range("I" & O).Value = WorksheetFunction.VLookup(Range("H" & O), Range("N2:O666600"), 2, 0)
Next
Application.ScreenUpdating = True
End Sub



Sub boya()
On Error Resume Next
Application.ScreenUpdating = False
Range("O5:O6600").Font.ColorIndex = xlNone
For i = 5 To 6600
If Range("N" & O).Value = "ALİ" Then Range("O" & O).Font.ColorIndex = 3
Next
Application.ScreenUpdating = True
End Sub

Merhaba
Yanlış yaptığınız kısım
If Range("N" & O).Value = "ALİ" Then Range("O" & O).Font.ColorIndex = 3
Doğrusu

If Range("N" & i).Value = "ALİ" Then Range("O" & i).Font.ColorIndex = 3
Şeklinde olacak burdaki i döngü için gerekli


Bu şu demek
Eğer "N" sutunundaki hücrelerde ALİ Yazıyorsa "O" sutunundai hücrelerdeki yazıları kırmızıya çevir
Siz bu Ali kısmını kendi dosyanıza göre değiştirebilirsiniz
buna ekleme yapabilirsiniz
Örn:

If Range("N" & i).Value = "ALİ" Then Range("O" & i).Font.ColorIndex = 3
If Range("N" & i).Value = "Veli" Then Range("O" & i).Font.ColorIndex = 5

Ayrıca
If Range("H" & O).Value > "" Then Range("I" & O).Value = WorksheetFunction.VLookup(Range("H" & O), Range("N2:O666600"), 2, 0)
6600 şeklinde düzeltirmisiniz

 

[sratacc]

Merhaba
Yanlış yaptığınız kısım
If Range("N" & O).Value = "ALİ" Then Range("O" & O).Font.ColorIndex = 3
Doğrusu

If Range("N" & i).Value = "ALİ" Then Range("O" & i).Font.ColorIndex = 3
Şeklinde olacak burdaki i döngü için gerekli


Bu şu demek
Eğer "N" sutunundaki hücrelerde ALİ Yazıyorsa "O" sutunundai hücrelerdeki yazıları kırmızıya çevir
Siz bu Ali kısmını kendi dosyanıza göre değiştirebilirsiniz
buna ekleme yapabilirsiniz
Örn:

If Range("N" & i).Value = "ALİ" Then Range("O" & i).Font.ColorIndex = 3
If Range("N" & i).Value = "Veli" Then Range("O" & i).Font.ColorIndex = 5

Ayrıca
If Range("H" & O).Value > "" Then Range("I" & O).Value = WorksheetFunction.VLookup(Range("H" & O), Range("N2:O666600"), 2, 0)
6600 şeklinde düzeltirmisiniz

anlaşılır anlatımınız için teşekkür ederim sayın numan şamil. ancak söylediğiniz gibi yapmama rağmen ben çalıştıramadım dosyayı gönderiyorum.

teşekkürler

 

[numan şamil]

anlaşılır anlatımınız için teşekkür ederim sayın numan şamil. ancak söylediğiniz gibi yapmama rağmen ben çalıştıramadım dosyayı gönderiyorum.

teşekkürler

Merhaba
H sutnundaki hücrelerden
İşlem yapılmadı. seçilirse işlem yapılmadı kelimesini kırmızı ile yazıyor
Denermisiniz

 

[sratacc]

Merhaba
H sutnundaki hücrelerden
İşlem yapılmadı. seçilirse işlem yapılmadı kelimesini kırmızı ile yazıyor
Denermisiniz

Yardımlarınız ve ilginiz için teşekkür ederim sayın numan şamil.

 

[numan şamil]

Yardımlarınız ve ilginiz için teşekkür ederim sayın numan şamil.

Kolay gelsin

 

[oydemir]

=Düşeyara(E2;H:I,2,0) için

Sub işlemyap1()
On Error Resume Next
Application.ScreenUpdating = False
For i = 2 To 600
If Range("e" & i).Value > "" Then Range("f" & i).Value = WorksheetFunction.VLookup(Range("e" & i), Range("H2:I600"), 2, 0)
Next
Application.ScreenUpdating = True
End Sub

son satıra kadar nasıl uygunluya bilirim