private sub worksheet_change hakkında

[bravo64]

Merhaba tekrar sevgili arkadaşlar,
Private sub worksheet_change de yazdığım kod tabloya veri aktarıyor ve girilen değere göre vlookup ile yanındaki hücreye fiyatını getiriyor.Yalnız değer girildikten sonra worksheet_change in çalışması ve fiyatı getirmesi için enter yada tab yapmak gerekiyor..Bu tamam,acaba değer girildiği anda kod çalışamazmı?

 

[bravo64]

Tabloya değeri veri doğrulama ile giriyorum..

 

[Levent Menteşoğlu]

Yazar yazmaz maalesef çalıştıramazsınız, fakat veri doğrulama ile yapılmış bir açılır liste kullanıyorsanız, veriyi seçer seçmez kod çalışacaktır.

 

[bravo64]

sevgili leventm,veri doğrulama ile değer giriyorum ama hemen çalışmıyor.değer girildikten sonra herhangibir hücreyi click yaptığım zaman çalışıyor..

 

[Levent Menteşoğlu]

Ekteki örneği inceleyin.

 

[bravo64]

benim kodlarım şöyle,eğer bakabilirseniz sevinirim.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim düşey As Integer
On Error Resume Next
Set s1 = Sheets("tabela sa-1")
Set s2 = Sheets("stokraporu")
alan = s2.Range("b3:l500")
For düşey = 16 To 22
ara = s1.Cells(düşey, 1)
If s1.Cells(düşey, 1) <> "" And WorksheetFunction.VLookup(ara, alan, 5, 0) > 0 Then
s1.Cells(düşey, 7) = WorksheetFunction.VLookup(ara, alan, 4, 0)
Else
s1.Cells(düşey, 7) = WorksheetFunction.VLookup(ara, alan, 10, 0)
End If
If s1.Cells(düşey, 1) = "" Then s1.Cells(düşey, 7) = ""
Next
Set s1 = Sheets("tabela sa-1")
Set s2 = Sheets("stokraporu")
alan = s2.Range("b3:l500")
For düşey = 28 To 39
ara = s1.Cells(düşey, 1)
If s1.Cells(düşey, 1) <> "" And WorksheetFunction.VLookup(ara, alan, 5, 0) > 0 Then
s1.Cells(düşey, 7) = WorksheetFunction.VLookup(ara, alan, 4, 0)
Else
s1.Cells(düşey, 7) = WorksheetFunction.VLookup(ara, alan, 10, 0)
End If
If s1.Cells(düşey, 1) = "" Then s1.Cells(düşey, 7) = ""
Next
Set s1 = Sheets("tabela sa-1")
Set s2 = Sheets("stokraporu")
alan = s2.Range("b3:l500")
For düşey = 46 To 56
ara = s1.Cells(düşey, 1)
If s1.Cells(düşey, 1) <> "" And WorksheetFunction.VLookup(ara, alan, 5, 0) > 0 Then
s1.Cells(düşey, 7) = WorksheetFunction.VLookup(ara, alan, 4, 0)
Else
s1.Cells(düşey, 7) = WorksheetFunction.VLookup(ara, alan, 10, 0)
End If
If s1.Cells(düşey, 1) = "" Then s1.Cells(düşey, 7) = ""
Next
End Sub
nereyi yada nereleri düzeltmem lazım acaba ?

 

[Levent Menteşoğlu]

Kodlarınızı "Private Sub Worksheet_SelectionChange(ByVal Target As Range)" olayına yazmışsınız hatanız burada, bu olayda içeriği değiştiğinde değil hücre seçildiğinde kod çalışacaktır, kodu worksheet_change() olayına yazarak deneyin. Benim eklediği dosyada bu olaya yazılmıştır.

 

[bravo64]

Tamam söylediğiniz gibi yaptım..Bu sefer sistem kilitleniyor..Ã?nce cursor titriyor sonra kilitleniyor..

 

[Levent Menteşoğlu]

Bunun sebebini kodlara bakarak söylemek mümkün değil, dosyanızı eklerseniz onun üzerinden gidelim.

 

[bravo64]

dosya ekte yer alıyor..Zahmet olacak size..
çok teşekkürler..

 

[Levent Menteşoğlu]

Aşağıdaki kodu deneyin. Bu kod hücreden değer seçtiğiniz anda o değere ait veriyi bulacaktır.

[vb:1:a6f62b3d81]Private Sub Worksheet_Change(ByVal Target As Range)
Dim düşey As Integer
On Error Resume Next
Set s1 = Sheets("tabela sa-1")
Set s2 = Sheets("stokraporu")
If Intersect(Target, [a:a]) Is Nothing Then Exit Sub
Set alan = s2.Range("b3:l500")
ara = Target.Value
düşey = Target.Row
If Target <> "" And WorksheetFunction.VLookup(ara, alan, 5, 0) > 0 Then
s1.Cells(düşey, 7) = WorksheetFunction.VLookup(ara, alan, 4, 0)
Else
s1.Cells(düşey, 7) = WorksheetFunction.VLookup(ara, alan, 10, 0)
End If
If Target = "" Then s1.Cells(düşey, 7) = ""
End Sub[/vb:1:a6f62b3d81]

 

[bravo64]

Süper oldu sevgili leventm,çok teşekkür ederim..