Son değiştirilen hücreyi bulmak

[hmtstc]

Merhaba arkadaşlar,

bir tablom var ve aşağıdaki formülle tablodaki seçili alandaki değişiklik durumunda 1. sütuna "eksik" yazdırmaya çalışıyorum. ancak değişimdeki 2 koşulu kontrol etmesini istiyorum.

1.si ilk değer ile son değeri kıyaslayacak ve aynı ise "eksik" yazmayacak !

2. si ise değişen satırın en son sütununa "eksik" yazacak. ( ben yaptığımda değişen satırın alt satırına yapıyor ( enter ile değiştirdiğim için, tab ile değiştirirsem sorun yok. )

yardımınızı rica ederim...

Sub Worksheet_Change(ByVal Target As Range)

Dim KeyCells7 As Range
On Error GoTo 100
'
'
Set KeyCells7 = Sheets("veritabanı").Range("F9:CH60000")
If Not Application.Intersect(KeyCells7, Range(Target.Address)) Is Nothing Then
i = ActiveCell.Row
Sheets("veritabanı").Select
Cells(i, 1) = "Eksik"
End If
100
Exit Sub
End Sub

 

[alicimri]

Sorunuzun 2. kısmı için

i = ActiveCell.Row

satırını

i = Target.Row

şeklinde değiştirin.
1. Kısmını anlamadım.

 

[alicimri]

Bu makroda başka kod satırları yoksa Kırmızı olan ifadeler gereksiz gibi geldi bana.

Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells7 As Range
[COLOR="Red"]On Error GoTo 100[/COLOR]
'
'
Set KeyCells7 = [COLOR="Red"]Sheets("veritabanı").[/COLOR]Range("F9:CH60000")
If Not Application.Intersect(KeyCells7, Range(Target.Address)) Is Nothing Then
i = Target.Row
[COLOR="Red"]Sheets("veritabanı").Select[/COLOR]
Cells(i, 1) = "Eksik"
End If
[COLOR="Red"]100
Exit Sub[/COLOR]
End Sub

 

[hmtstc]

alicimri bey ilk yorumdaki belirttiğiniz şekilde çözdüm. Çok teşekkür ederim.

Ancak şöyle bir durum var.

Hücreye girip değiştirirsem program çalışıyor. Ama hücreyi kopyala yapıştır metoduyla değiştirdiğimde çalışmıyor.

Yani örneğin e5 hücresini kopyaladım. e10:e20 arasına yapıştır yaptığımda sadece e10 da "eksik" yazıyor diğerlerinde yazmıyor.

hücrenin ilk değeri ile son değerini kıyaslayıp fark var ise "eksik" yazmalı.

yardım eder misiniz? şimdiden teşekkür ederim.

 

[alicimri]

hücrenin ilk değeri ile son değerini kıyaslayıp fark var ise .

İfadenizdeki kastınız, bir hücrede örneğin "123" yazıyor, o hücreye girerek veya kopyala yapıştır ile "456" yaptığınızda o hücrenin bulunduğu satırın A sütununa eksik yazması mı ?.

 

[hmtstc]

İfadenizdeki kastınız, bir hücrede örneğin "123" yazıyor, o hücreye girerek veya kopyala yapıştır ile "456" yaptığınızda o hücrenin bulunduğu satırın A sütununa eksik yazması mı ?.

Evet hocam aynen öyle...

Örneğin, E7 hücresinde "123" yazılı. daha sonra ben bunu hücre içine girerek yada başka bir hücreden kopyala yapıştır yaparak "456" yaptığımda aynı satırın 1. sütununa "eksik" yazmasını istiyorum.

Şöyle ki şuanda hücre içine girerek yaparsam oluyor.
Ama E7 yi kopyalayıp E10:E20 aralığında yaptığımda sadece E10' a eksik yazıyor. diğerlerine yazmıyor.

Bir de hücre içindeki değer örneğin 3 ve ben hücre içine girip yeniden 3 yazdığımda yine eksik yazıyor. ama aslında değer değişmemiş oluyor. önceki ile sonrakini kıyaslaması gerekiyor dediğim şey bu aslında.

 

[alicimri]

Aşağıdaki kodu deneyin. Biraz test ettim sorun çıkmadı.

Dim dizi As String
Private Sub Worksheet_Change(ByVal Target As Range)

If Not Application.Intersect(Range("F9:CH60000"), Range(Target.Address)) Is Nothing Then

If Application.CutCopyMode = 0 Then
If dizi = "" Then dizi = "Bos"
If Target <> Split(dizi, "qq")(0) Or dizi = "" Then
Range("A" & Target.Row).Value = "EKSİK"
Else
Range("A" & Target.Row).Value = ""
End If
Else
say = 0
ilk = Target.Row
son = (Target.Row + Selection.Count) - 1
For i = Target.Row To (Target.Row + Selection.Count) - 1
If dizi = "" Then dizi = "Bos"
If Split(dizi, "qq")(say) <> Cells(i, Target.Column) Then
Range("A" & i) = "EKSİK"
Else
Range("A" & i) = ""
End If
say = say + 1
Next
End If
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Application.Intersect(Range("F9:CH60000"), Range(Target.Address)) Is Nothing Then
dizi = ""
For i = Target.Row To (Target.Row + Selection.Count) - 1
dizi = dizi & "qq" & Cells(i, Target.Column)
Next
dizi = Mid(dizi, 3)
End If
End Sub

 

[alicimri]

Kodları yukardaki mesaja ekledim. Kopyalanacak hücrenin tek, yapıştırılacak sütunun da tek sütun olması gerekiyor.

 

[hmtstc]

hocam merhaba, konu hortlatmak gibi olacak ama, sizin yazdığınız kodlarla çalışıyorum da sürekli hata alıyorum. hata ekranı ayarladım çoklu koplayama durumu için sürekli uyarı veriyor çünkü sürekli çoklu seçim değişkenlik oluyor. Baya denedim kurcaladım ama bulamadım çözümünü. Çoklu değişme durumlarında da sistemi nasıl çalıştırabiliriz ? Yardımınızı rica ederim.

 

[hmtstc]

Sub Worksheet_Change(ByVal Target As Range)
Dim dizi As String
On Error Resume Next
ssson = Sheets("veritabanı").Cells(Rows.Count, "A").End(xlUp).Row
'
If Not Application.Intersect(Range("T9:CI" & ssson), Range(Target.Address)) Is Nothing Then
If Application.CutCopyMode = 0 Then
say = 0
ilk = Target.Row
son = (Target.Row + Selection.Rows.Count) - 1
For i = ilk To son
If dizi = "" Then dizi = "Bos"
If Target <> Split(dizi, "qq")(0) Or dizi = "" Then Range("A" & i).Value = "Eksik"
say = say + 1
Next i
Else
say = 0
ilk = Target.Row
son = (Target.Row + Selection.Rows.Count) - 1
For i = ilk To son
If dizi = "" Then dizi = "Bos"
If Split(dizi, "qq")(say) <> Cells(i, Target.Column) Then Range("A" & i) = "Eksik"
say = say + 1
Next i
End If
End If
ason = Cells(Rows.Count, "A").End(xlUp).Row
bson = Cells(Rows.Count, "A").End(xlUp).Row
If ason > bson Then
Range(Cells(bson + 1, 1), Cells(ason, 1)).Select
Selection.ClearContents
End If
Exit Sub
100
MsgBox "Kopyalama Hatası. Lütfen copy - paste metodu ile kopyalayın. Güncel/Eksik detaylarını satırlar için kontrol edin.", vbInformation, "Kopyalama Hatası"
Exit Sub
End Sub
------------------------
Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
ssson = Sheets("veritabanı").Cells(Rows.Count, "A").End(xlUp).Row
If Not Application.Intersect(Range("T9:CI" & ssson), Range(Target.Address)) Is Nothing Then
dizi = ""
For i = Target.Row To (Target.Row + Selection.Count) - 1
dizi = dizi & "qq" & Cells(i, Target.Column)
Next
dizi = Mid(dizi, 3)
End If
ason = Cells(Rows.Count, "A").End(xlUp).Row
bson = Cells(Rows.Count, "B").End(xlUp).Row
If ason > bson Then
Range(Cells(bson + 1, 1), Cells(ason, 1)).Select
Selection.ClearContents
End If
1001
End Sub

Uğraşırken çözdüm, desteğiniz için yine de teşekkür ederim.