Workbook_SheetChange olayına bir sayfayı dahil etmemek

[dEdE]

Merhaba,
Aşağıdaki kodlarla tüm sayfaların B28 hücresini kontrol ediyorum. Sayfa sayısı fazla olduğundan kodu her sayfaya yazmak istemedim.
Ancak, Sayfa1 bu kontrole dahil olmamalı. Yani Sayfa1'in B28'inde değşiklik yapıldığında Select Case kodu çalışmamalı.

Bunu nasıl sağlarız.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Intersect(Target, [B28]) Is Nothing Then Exit Sub
    Select Case [B28].Value
        Case ("Ali"): [H28] = 50
        Case ("Veli"): [H28] = 0.6
        Case ("Selami"): [H28] = 15 
    End Select
End Sub

 

[Levent Menteşoğlu]

Aşağıdaki satırı kod içine ilk satır olarak ekleyin.

if sh.name="Sayfa1" then exit sub

 

[dEdE]

Merhaba,
Yanıt için teşekkürler. Ancak olmadı. Ekli dosyadaki Stok Aktar butonuna bastığımda hata veriyor. Galiba sorun diğer kodlarda.

 

[leumruk]

Selamlar,

Sub Makro()
    Application.EnableEvents = False
    'Kodlarınız
    Application.EnableEvents = True
End Sub

Sanırım bu kodlar sorununuzu çözecektir.

 

[dEdE]

Teşekkürler.

Malesef olmadı.

 

[leumruk]

Ekli dosyayı inceleyiniz. Kodları ilgili aktarma makronuza yerleştirdim.

 

[dEdE]

Merhaba,
Dosyanın yapısı şöyle.

Stok sayfasının kod bölümünde otomatik köprü oluşturan kod var.
ThisWorkbook ta Sayfaların B28 hücresini kontrol ederek H28 için seçim yapan kod var
Ayrıca modül içinde Sayfaların bir bölümünü stok sayfasına aktaran kod var.
Sayfaların B28 hücresinde ise veri doğrulama ile oluşturulmuş liste var.
Modüldeki kod çalışınca (stok Aktar) ThisWorkbook taki Target satırı hata veriyordu.

Son ekleme ile düzeldi ama bu defa stok sayfasındaki makro devre dışı kaldı. Artık otomatik köprü oluşturmuyor.

 

[leumruk]

Syn. DEDE,

Sub StokAktar()
Set S1 = ActiveSheet
Set S2 = Sheets("Stok")
Application.EnableEvents = False
For i = 10 To 24
    If Cells(i, 2).Value <> "" Then
        With S2
            ssA = IIf(.Cells(1, 1) = "", 1, .[A65536].End(3).Row + 1)
            .Range("A" & ssA & ":H" & ssA).Value = S1.Range("B" & i & ":I" & i).Value
            .Cells(ssA, 9) = S1.Cells(3, 2)
        End With
    End If
Next
[COLOR="Red"]S2.Select
Application.EnableEvents = True
Range("I1").Copy Range("I1")
S1.Select[/COLOR]
End Sub

Kırmızı satırların sorunu çözmüş olması lazım. I1 hücresiyle yapay bir tetikleme oluşturdum.

 

[dEdE]

Teşekkürler.