• DİKKAT

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

Sağ Tık satır silme uyarısı

O

oguz demirbas

Katılım
16 Temmuz 2005
Mesajlar
151
Excel Vers. ve Dili
2000 türkçe
Değerli kardeşlerim;

sağ tık ile satırı silme işlemi yaptığımda bir uyarı mesajı almak istiyorum.

buna göre "H" sütununda silinecek satıra ait bir veri VAR ise "Silmek istediğinizden emin misiniz?" evet : sil hayır ise silme

"H" sütununda silinecek satıra ait bir veri YOK ise silme işlemi yapılacak


uygun bir kod yazılabilir mi?

teşekkür ederim
 
Aşağıdaki kod boş bir modüle uygulayın.

Dosyanızı kayıt edip kapatıp açın.

Sonra sayfanızda sağ tıklama ile silme işlemi yapmayı deneyin.

Kod: 
Sub Auto_Open()
    On Error Resume Next
    
    For Each Menu In Application.CommandBars("Row").Controls
        If Menu.FaceId = 293 Then
            Menu.OnAction = "Sil"
        End If
    Next
    
    For Each Menu In Application.CommandBars("Column").Controls
        If Menu.FaceId = 294 Then
            Menu.OnAction = "Sil"
        End If
    Next
    
    For Each Menu In Application.CommandBars("Cell").Controls
        If Menu.FaceId = 292 Then
            Menu.OnAction = "Sil"
        End If
    Next
End Sub

Sub Sil()
    For Each Veri In Selection
        If Cells(Veri.Row, "H") <> "" Then
            Say = Say + 1
        End If
    Next
    If Say > 0 Then
        Onay = MsgBox("Silmek istediğinize emin misiniz?", vbCritical + vbYesNo)
        If Onay = vbYes Then
            Selection.EntireRow.Delete
        End If
    Else
        Selection.Delete xlUp
    End If
End Sub
 
Korhan Bey teşekkür ederim. Kod çalışıyor.

Aynı mantıkla yapıştırılmak istenilen satırda bulunan firma adını diğer sayfadan kontrolünü nasıl yapabiliriz? Kullanıcılar sık sık siparişlerde bulunan firma isimlerini LOGO dan çekerken hatalı yazıyorlar.

bir kod denemem oldu ancak başaramadım:

autoopen kodları (sağ klik yapıştırma işlemi için):

For Each Menu In Application.CommandBars("Row").Controls
If Menu.FaceId = 6002 Then
Menu.OnAction = "yapistir"
End If
Next
For Each Menu In Application.CommandBars("Row").Controls
If Menu.FaceId = 22 Then
Menu.OnAction = "yapistir"
End If
Next
For Each Menu In Application.CommandBars("Row").Controls
If Menu.FaceId = 879 Then
Menu.OnAction = "yapistir"
End If
Next
For Each Menu In Application.CommandBars("Row").Controls
If Menu.FaceId = 21437 Then
Menu.OnAction = "yapistir"
End If
Next
For Each Menu In Application.CommandBars("Row").Controls
If Menu.FaceId = 1956 Then
Menu.OnAction = "yapistir"
End If
Next
For Each Menu In Application.CommandBars("Row").Controls
If Menu.FaceId = 755 Then
Menu.OnAction = "yapistir"
End If
Next
For Each Menu In Application.CommandBars("Row").Controls
If Menu.FaceId = 1956 Then
Menu.OnAction = "yapistir"
End If
Next


kontrol etmesi için:

Sub yapistir()


' sayfa1 de yapıştırma işlemi uygulanacak satır
' k sütununda bulunan veriyi kontrol edecek

X = Sheets("sayfa1").Cells(Veri1.Row, "k")

' source sayfasında bulunan firma isimlerinin kontrolünü sağlayacak kod


For Each bak In Sheets("source").Range("d1:d" & WorksheetFunction.CountA(Range("d1:d15")))
If StrConv(bak.Value, vbUpperCase) = StrConv(X.Value, vbUpperCase) Then
bak.Select
say = say + 1
End If
Next

If say > 0 Then
onay2 = MsgBox("Uygun Firma Seçimi yapmadınız", vbCritical + vbYesNo)
If onay2 = vbYes Then
Selection.PasteSpecial
End If
' sonuç hayır olsa da yapıştırma işlemini yapacak. En azından kullanıcı hatalı giriş yaptığının farkında olsun.
Else
Selection.PasteSpecial xlPasteAll
End If

End Sub
 
Bu şekilde de denedim:

For Each Menu In Application.CommandBars("Row").Controls
If Menu.FaceId = 6002 Then
Menu.OnAction = "yapistir"
End If
Next
For Each Menu In Application.CommandBars("Row").Controls
If Menu.FaceId = 22 Then
Menu.OnAction = "yapistir"
End If
Next
For Each Menu In Application.CommandBars("Row").Controls
If Menu.FaceId = 879 Then
Menu.OnAction = "yapistir"
End If
Next
For Each Menu In Application.CommandBars("Row").Controls
If Menu.FaceId = 21437 Then
Menu.OnAction = "yapistir"
End If
Next
For Each Menu In Application.CommandBars("Row").Controls
If Menu.FaceId = 1956 Then
Menu.OnAction = "yapistir"
End If
Next
For Each Menu In Application.CommandBars("Row").Controls
If Menu.FaceId = 755 Then
Menu.OnAction = "yapistir"
End If
Next


End Sub



Sub yapistir()

Selection.PasteSpecial

Dim X As String
For Each Veri In Selection
X = Cells(Veri.Row, "k")
If Cells(Veri.Row, "k") <> "" Then
Call kontrol
say = say + 1
End If
Next
If say > 0 Then
onay2 = MsgBox("Uygun Firma Seçimi yapmadınız", vbCritical + vbYesNo)
If onay2 = vbYes Then
Selection.PasteSpecial
End If

Else
Selection.PasteSpecial xlPasteAll
End If
End Sub
Sub kontrol()
Dim bak As Range
Dim ad As String
ad = Cells(Veri.Row, "k")
For Each bak In Sheets("source").Range("d1:d" & WorksheetFunction.CountA(Range("d1:d15")))
If StrConv(bak.Value, vbUpperCase) = StrConv(ad.Value, vbUpperCase) Then
bak.Select
End If
Next


End Sub
 
Yapıştırma işlemini tam anlamadım.

Örnek dosya ekleme şansınız var mı?
 
Korhan Bey;

İlginiz için çok teşekkür ederim. Yetersiz ifadem için de kusura bakmayın. Yoğunluktan tam anlatamadım.

Yukarıda belirtilen sağ tıklama özelliğini biraz daha geliştirmek istedim. Şöyle ki;

1. Kullanıcılar başka bir excel dosyasından sağ tık ile satırı kopyalayıp çıkıyorlar.

2. Daha sonra olması gereken diğer excel sayfasının en son satırına ise yapıştırıyorlar.

3. İş te tam bu noktada yapıştırma işlemini denetlemek istiyorum.

3.1. verilerin Yapıştırıldığı sayfa adı "sayfa1"
3.2. yapıştırılma işlemi sonrası "K" sütununda bulunan veriyi "source" sayfasında bulunan d1:d15 'e kadar yazılı olan firma adları ile kontrol etmek istiyorum.

Örneğin yapıştırma işlemi yapıldıktan sonra "k" sütununda ki firma adı "Ülker" ise;

bu veri "soruce" sayfasında ki d1:d15 'e kadar olan firma adları ile kontrol edilecek. Eşleşme sağlanırsa Firma adı doğru
Sağlanamazsa firma adı hatalı diye bir uyarı aldırmak istiyorum.

Not: Bu işi yaptırmak istemenin temel amacı büyük harf küçük harf ve hatalı yazmaları özellikle önüne geçmeye çalışmak.
 

Ekli dosyalar

Bunun için sayfanızın kod bölümünü kullanmanız yeterli olacaktır.

Sayfa1 isimli sayfanızın kod bölümüne aşağıdaki kodu uygulayınız.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A:K")) Is Nothing Then Exit Sub
    For Each Veri In Sheets("source").Range("D1:D15")
        If Veri.Value = Cells(Target.Row, "K") Then Say = Say + 1
    Next
    If Say = 0 Then
        Onay = MsgBox("Uygun firma seçimi yapmadınız !", vbCritical + vbYesNo)
        If Onay = vbYes Then
            Application.EnableEvents = False
            On Error Resume Next
            Selection.PasteSpecial
            On Error GoTo 0
        End If
    End If
    Application.EnableEvents = True
End Sub
 
Korhan Bey;

Bir sıkıntı var;

silme işlemini makro içermeyen hiç alakası olmayan bir dosyada da bu işlemi yapmaya calışıyor.

hatta "sil" makrosu bulunan dosyayı da açıyor.

Anlamadım gitti....
 
Tüm kullanıcılar bu durumdan muzdarip olmuş durumda. 10 taneye yakın makine var... ne yapacağımı şaşırdım.
 

Ekli dosyalar

  • ek.jpg
    ek.jpg
    256.8 KB · Görüntüleme: 6
Merhaba,

Kodları düzeltmemiz gerekiyor. Aşağıdaki adımları uygulayın.

Dosyanızın yedeğini alarak bu işlemleri yapın.

Daha önceki verdiğim kodları silin.

Dosyanıza boş bir modüle ekleyin ve aşağıdaki kodu uygulayın.

Kod: 
Sub Menu_Aktif()
    Dim Menu As CommandBarControl
    
    On Error Resume Next
    
    For Each Menu In Application.CommandBars("Row").Controls
        If Menu.FaceId = 293 Then
            Menu.OnAction = "Sil"
        End If
    Next
    
    For Each Menu In Application.CommandBars("Column").Controls
        If Menu.FaceId = 294 Then
            Menu.OnAction = "Sil"
        End If
    Next
    
    For Each Menu In Application.CommandBars("Cell").Controls
        If Menu.FaceId = 292 Then
            Menu.OnAction = "Sil"
        End If
    Next
End Sub

Sub Menu_Pasif()
    Dim Menu As CommandBarControl
    
    On Error Resume Next
    
    For Each Menu In Application.CommandBars("Row").Controls
        If Menu.FaceId = 293 Then
            Menu.Reset
        End If
    Next
    
    For Each Menu In Application.CommandBars("Column").Controls
        If Menu.FaceId = 294 Then
            Menu.Reset
        End If
    Next
    
    For Each Menu In Application.CommandBars("Cell").Controls
        If Menu.FaceId = 292 Then
            Menu.Reset
        End If
    Next
End Sub

Sub Sil()
    For Each Veri In Selection
        If Cells(Veri.Row, "H") <> "" Then
            Say = Say + 1
        End If
    Next
    If Say > 0 Then
        Onay = MsgBox("Silmek istediğinize emin misiniz?", vbCritical + vbYesNo)
        If Onay = vbYes Then
            Selection.EntireRow.Delete
        End If
    Else
        Selection.Delete xlUp
    End If
End Sub


Daha sonra dosyanızın "BuÇalışmaKitabı" ya da "ThiswokBook" bölümüne aşağıdaki kodu uygulayın.

Kod: 
Private Sub Workbook_Activate()
    Menu_Aktif
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Menu_Pasif
End Sub

Private Sub Workbook_Deactivate()
    Menu_Pasif
End Sub

Private Sub Workbook_Open()
    Menu_Aktif
End Sub


İlgili sayfanızın kod bölümüne aşağıdaki kodu uygulayın.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A:K")) Is Nothing Then Exit Sub
    For Each Veri In Sheets("source").Range("D1:D15")
        If Veri.Value = Cells(Target.Row, "K") Then Say = Say + 1
    Next
    If Say = 0 Then
        Onay = MsgBox("Uygun firma seçimi yapmadınız !", vbCritical + vbYesNo)
        If Onay = vbYes Then
            Application.EnableEvents = False
            On Error Resume Next
            Selection.PasteSpecial
            On Error GoTo 0
        End If
    End If
    Application.EnableEvents = True
End Sub



Dosyanızı kayıt edip kapatıp açın. İlgili dosyanızda kurguladığımız kod çalışırken başka dosyayı açtığınızda ya da aktif ettiğinizde SİL makrosu devre dışı kalacaktır.

Denemeler yapıp sonucu bildiriniz.
 
Sorun halloldu... teşekkür ederim
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst