Veri Girişi ya da silme de uyarı alma

[Yesilyurtlu]

N11:Q54 arasında bir hücreye veri girişi ya da silme işlemini yaptığımız zaman
Örneğin :
Bu silme işlemini O47 hücresinde yaptığım zaman
Veri silme işlemi yaptınız Lütfen H47 hücresini güncelleyiniz
ya da
Veri girme işlemini M19 hücresinde yaptığım zaman
Veri giriş işlemi yaptınız Lütfen H19 hücresini güncelleyiniz
yani hangi satırda N11:Q54 arasında işlem yapılmışsa o satırın H sütunu için
uyarı verdirebilmem mümkün mü?

Teşekkür Ederim

 

[Ömer]

N11:Q54 arasında bir hücreye veri girişi ya da silme işlemini yaptığımız zaman o satırın H sütunu için uyarı verdirebilmem mümkün mü?

Merhaba,

Çalışma sayfasının kod bölümüne kopyalayınız.

Public deg
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    deg = Target
End Sub
 
Private Sub Worksheet_Change(ByVal Target As Range)
 
    If Intersect(Target, [N11:Q54]) Is Nothing Then Exit Sub
 
    If deg <> Target Then
        [COLOR=blue]Range("H" & Target.Row).Select[/COLOR]
        MsgBox "H" & Target.Row & " Hücresini Güncelleyiniz"
    End If
 
End Sub

Uyarı verdirme işleminin dışında, imleç H sütunu aynı satırdaki hücreye gider. Eğer bu özelliği istemezseniz kodlardaki mavi satırı silersiniz.

.

 

[Yesilyurtlu]

Ömer abi teşekkür ederim
Ellerine sağlık

 

[Yesilyurtlu]

Private Sub Worksheet_Change(ByVal Target As Range)
Dim S1 As Worksheet, c As Range
Set S1 = Sheets("ALACAKLI")
If Not Intersect(Target, [C:C]) Is Nothing Then
With Target
Set c = S1.[C:C].Find(.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
.Offset(0, 1) = S1.Range("D" & c.Row)
.Offset(0, 2) = S1.Range("E" & c.Row)
.Offset(0, 3) = S1.Range("F" & c.Row)
'.Offset(0, 5) = S1.Range("G" & c.Row)
.Offset(0, 7) = S1.Range("H" & c.Row)
.Offset(0, 4) = S1.Range("ı" & c.Row)
Else
Range("D" & .Row & ":s" & .Row).ClearContents
MsgBox "Veriyi Bulamadım"
End If
End With
ElseIf Not Intersect(Target, Range("H11:H65536")) Is Nothing Then
Cells(Target.Row, "I") = Cells(Target.Row, "G") * Cells(Target.Row, "H")
Cells(Target.Row, "K") = Cells(Target.Row, "I") * Cells(Target.Row, "J")
Cells(Target.Row, "L") = Cells(Target.Row, "I") + Cells(Target.Row, "K")
Cells(Target.Row, "M") = Cells(Target.Row, "I") * 0.00825
Cells(Target.Row, "R") = Cells(Target.Row, "M") + Cells(Target.Row, "N") + Cells(Target.Row, "O") + Cells(Target.Row, "P") + Cells(Target.Row, "Q")
Cells(Target.Row, "S") = Cells(Target.Row, "L") - Cells(Target.Row, "R")
End If
End Sub



Ömer Abi Yukarıda ki makroyu eklediğim makroya ekleyebilmeme yardımcı olabilir misin abi sana zahmet?

 

[Ömer]

Yukarıda ki makroyu eklediğim makroya ekleyebilmeme yardımcı olabilir misin abi sana zahmet?

Bu şekilde deneyiniz.

[COLOR=blue]Public deg[/COLOR]
[COLOR=#000000][COLOR=blue]Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    deg = Target
End Sub
[/COLOR] 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, c As Range
 
    Set S1 = Sheets("ALACAKLI")
    
    [COLOR=red]On Error GoTo atla
[/COLOR]    If Not Intersect(Target, [C:C]) Is Nothing Then
        With Target
            Set c = S1.[C:C].Find(.Value, LookIn:=xlValues, LookAt:=xlWhole)
            If Not c Is Nothing Then
                .Offset(0, 1) = S1.Range("D" & c.Row)
                .Offset(0, 2) = S1.Range("E" & c.Row)
                .Offset(0, 3) = S1.Range("F" & c.Row)
                '.Offset(0, 5) = S1.Range("G" & c.Row)
                .Offset(0, 7) = S1.Range("H" & c.Row)
                .Offset(0, 4) = S1.Range("ı" & c.Row)
            Else
                Range("D" & .Row & ":S" & .Row).ClearContents
            MsgBox "Veriyi Bulamadım"
            End If
        End With
    ElseIf Not Intersect(Target, [H11:H65536]) Is Nothing Then
        Cells(Target.Row, "I") = Cells(Target.Row, "G") * Cells(Target.Row, "H")
        Cells(Target.Row, "K") = Cells(Target.Row, "I") * Cells(Target.Row, "J")
        Cells(Target.Row, "L") = Cells(Target.Row, "I") + Cells(Target.Row, "K")
        Cells(Target.Row, "M") = Cells(Target.Row, "I") * 0.00825
        Cells(Target.Row, "R") = Cells(Target.Row, "M") + Cells(Target.Row, "N") + _
                                 Cells(Target.Row, "O") + Cells(Target.Row, "P") + _
                                 Cells(Target.Row, "Q")
        Cells(Target.Row, "S") = Cells(Target.Row, "L") - Cells(Target.Row, "R")
    [COLOR=blue]ElseIf Not Intersect(Target, [N11:Q54]) Is Nothing Then
        If deg <> Target Then
            Range("H" & Target.Row).Select
            MsgBox "H" & Target.Row & " Hücresini Güncelleyiniz"
        End If
[/COLOR]    End If
[COLOR=red]    Exit Sub
atla:
[/COLOR]    
End Sub[/COLOR]

.

 

[Yesilyurtlu]

If deg <> Target Then

satırında hata verdi ömer abi

 

[Ömer]

Dosya ekleyebilirmisiniz.

 

[Yesilyurtlu]

Ömer Abi Dosya ekde
B11 hücresine Çift tıklayınca "If deg <> Target Then" sarı renkte Hata veriyor.

 

[Ömer]

Sayfada farklı kodlarınızda varmış. Çift tıklama ile silinecek alan [N11:Q54] alanın içinde olduğu için hata alıyordunuz.

#5 numaralı mesajdaki kodları yeniledim, tekrar deneyiniz.

.

 

[Yesilyurtlu]

Ömer Abi Ellerine Sağlık
Zahmet verdim ise kusuruma bakma ne olur.
Yardımını esirgemediğin için Teşekkür ederim abi.

 

[Ömer]

Rica ederim. Yardımcı olabildiysem ne mutlu.