• DİKKAT

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

sayfada makro

A

arzum2000

Katılım
8 Kasım 2009
Mesajlar
68
Excel Vers. ve Dili
2003
Aşağıdaki makro çalıştıktan sonra değerin üzerine tıklanınca tekrar kendisiyle çarpıyor.hesaplanmış Değerin üzrine tıklandığında değişmemesi için ne yapmak gerekir.Selamlarımla.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, [B23:J45]) Is Nothing Then Exit Sub
Application.EnableEvents = False
Target.Value = CDbl(((Cells(8, Target.Column).Value * Cells(9, Target.Column).Value _
* Cells(10, Target.Column).Value) / 1000000000) * Target.Value)
Application.EnableEvents = True
End Sub
 
Başlığı
Private Sub Worksheet_Change(ByVal Target As Range)
veya
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
olarak değiştirip deneyiniz.
 
Malesef ikisindede başka makrolar bulunuyor.Bu ifade ile yazmam gerek.
 
arzum2000' Alıntı:
Malesef ikisindede başka makrolar bulunuyor.Bu ifade ile yazmam gerek.
Genişletmek için tıkla ...
Merhaba,
Başka makroların bulunması önemli değil. Bu makroyu da gerekli şartı ekleyerek içine dahil edebilirsiniz. Kodları eklemeniz mümkünse, ekleyin, yardımcı olmaya çalışalım...
 
Aşağıdaki 3 makroyuda Worksheet_Change altında birleştirebilirmiyiz.?


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(ActiveCell, [I2,b5:J5]) Is Nothing Then Exit Sub
Takvim.Show

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, [B23:J45]) Is Nothing Then Exit Sub
Application.EnableEvents = False
Target.Value = CDbl(((Cells(8, Target.Column).Value * Cells(9, Target.Column).Value _
* Cells(10, Target.Column).Value) / 1000000000) * Target.Value)
Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim BUL As Range
On Error GoTo Son
If Intersect(Target, [B10:J11,B14,B16,C14,C16,D14,D16,E14,E16,F14,F16,G14,G16,H14,H16,I14,I16,J14,J16,K48:K63]) Is Nothing Then Exit Sub
If Range("K69") <> 0 Then Call MAKRO
Set BUL = Range("Y3:Y400").Find(Left(Cells(Target.Row, "L"), 2), LookAt:=xlWhole)
If Not BUL Is Nothing Then
If Range(BUL.Address).Interior.ColorIndex = 3 Then
Application.EnableEvents = False
Target = Empty
Application.EnableEvents = True
MsgBox "Bu kodda bölüm seçilemez!", vbCritical
End If
End If
Son: Application.EnableEvents = True
End Sub
 
Merhaba,
Aşağıdaki şekilde deneyin:
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim BUL As Range
On Error GoTo Son

If Not Intersect(Target, [I2,b5:J5]) Is Nothing Then
Takvim.Show
End If

If Not Intersect(Target, [B23:J45]) Is Nothing Then
Application.EnableEvents = False
Target.Value = CDbl(((Cells(8, Target.Column).Value * Cells(9, Target.Column).Value _
* Cells(10, Target.Column).Value) / 1000000000) * Target.Value)
Application.EnableEvents = True
End If


If Not Intersect(Target, [B10:J11,B14,B16,C14,C16,D14,D16,E14,E16,F14,F16,G1 4,G16,H14,H16,I14,I16,J14,J16,K48:K63]) Is Nothing Then
If Range("K69") <> 0 Then Call MAKRO
Set BUL = Range("Y3:Y400").Find(Left(Cells(Target.Row, "L"), 2), LookAt:=xlWhole)
If Not BUL Is Nothing Then
If Range(BUL.Address).Interior.ColorIndex = 3 Then
Application.EnableEvents = False
Target = Empty
Application.EnableEvents = True
MsgBox "Bu kodda bölüm seçilemez!", vbCritical
End If
End If
End If

Son: Application.EnableEvents = True
End Sub
 
Dosyada çalışmayan hücreleri sarıya boyadım.Selamlarımla.
 

Ekli dosyalar

Merhaba,
Kod çalışıyor, orada bir sorun yok; ancak kodunuz Takvimi açtığı için kullanışlı olmuyor. TAKVİM açan kodunuzu sağ clicke ekledim. Belirttiğiniz alanda sağ tıkladığınızda takvim açılacak.
 

Ekli dosyalar

J48 de seçim yapıyorum ancak k48 temizlemiyor ve msgbox açılmıyor.
 
J48 ile ilgili bir ifade yok ancak seçim yapılınca aşağıdaki kod çalışıyor belkide eklemekmi lazım?

Set BUL = Range("Y3:Y400").Find(Left(Cells(Target.Row, "L"), 2), LookAt:=xlWhole)
 
arzum2000' Alıntı:
J48 ile ilgili bir ifade yok ancak seçim yapılınca aşağıdaki kod çalışıyor belkide eklemekmi lazım?

Set BUL = Range("Y3:Y400").Find(Left(Cells(Target.Row, "L"), 2), LookAt:=xlWhole)
Genişletmek için tıkla ...

J48'in mantığını anlayamadım. Ama J48'de işlem yaptığınızda kodların çalışmasını istiyorsanız. Target olarak bu hücreyi de tanıtmalısınız. Belirttiğiniz kod aşağıdaki hücrelerde işlem yapıldığında çalışıyor. J48'i de dahil etmek istiyorsanız aşağıdaki satıra onu da ekleyin.
Kod: 
If Not Intersect(Target, [B10:J11,B14,B16,C14,C16,D14,D16,E14,E16,F14,F16,G14,G16,H14,H16,I14,I16,J14,J16,K48:K63]) Is Nothing Then
 
Set BUL = Range("Y3:Y400").Find(Left(Cells(Target.Row, "L"), 2), LookAt:=xlWhole)

J48 den sadece seçim yapılıyor yapılan seçime göre L 48 de kod oluşuyor şayet bu kod y sütununda kırmızı renk ise k48 siliniyor.Kodu tek başına change makrosuna yazarsam zaten çalışıyor ancak 2 makro beraber çalışmıyor.sorun bu.
 
If Intersect(Target, [B10:J11,B14,B16,C14,C16,D14,D16,E14,E16,F14,F16,G14,G16,H14,H16,I14,I16,J14,J16,K48:K63,Y3:Y400]) Is Nothing Then Exit Sub


bu şekilde denedim olmuyor.
 
Son düzenleme:
arzum2000' Alıntı:
Set BUL = Range("Y3:Y400").Find(Left(Cells(Target.Row, "L"), 2), LookAt:=xlWhole)

J48 den sadece seçim yapılıyor yapılan seçime göre L 48 de kod oluşuyor şayet bu kod y sütununda kırmızı renk ise k48 siliniyor.Kodu tek başına change makrosuna yazarsam zaten çalışıyor ancak 2 makro beraber çalışmıyor.sorun bu.
Genişletmek için tıkla ...

J48'i inceledim. Anladığım kadarıyla, J48'deki veriye göre k48'de seçim yaptığınızda duruma göre uyarı veriyor... Bu mantığa göre kodda bir sorun göremedim. Seçime göre uyarı mesajı veriyor. Kodların j48 ile bir ilgisi yok. J48'i formülle L sütununa bağlamışsınız. K48'de seçim yaptığınızda L sütunundaki ilgili kısma göre arama yapıyor ve duruma göre uyarı veriyor.
 
Selectıon change bağlı makroyu change altına yazınca oldu.Diğerinide worksheet _change ile yer değiştirdim.Teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst