A sütununa veri girdiğimde bütün son veri kalsın diğerleri silinsin

[teonet]

Merhaba
A sütununda herhangi bir satıra veri girdiğimde, son girdiğim veri kalacak diğer tüm verileri silecek bir macro yazabilir misiniz?

teşekkürlerimi sunarım.

 

[muhasebeciyiz]

Sub deneme()
Dim SonSatir As Long
Dim AktifHuc As Range

SonSatir = Cells(Rows.Count, "A").End(xlUp).Row

If SonSatir > 1 Then
If MsgBox("A sütunundaki tüm verileri silmek istediğinizden emin misiniz?", vbYesNo) = vbYes Then
Rows("1:" & SonSatir - 1).Delete
MsgBox "Veriler başarıyla silindi!", vbInformation
End If
End If
End Sub

 

[teonet]

Sub SilveSakla()
Dim SonSatir As Long
Dim AktifHuc As Range

Set AktifHuc = ActiveCell
SonSatir = Cells(Rows.Count, AktifHuc.Column).End(xlUp).Row

If SonSatir > 1 Then
Rows("1:" & SonSatir - 1).Delete
End If
End Sub

Merhaba değerli cevabınız için teşekkürler. Kodu yapıştırdım ama kodlar aktif olmadı sanırım. nasıl aktif edebilirim.

 

[zehirlee]

Merhaba
A sütununda herhangi bir satıra veri girdiğimde, son girdiğim veri kalacak diğer tüm verileri silecek bir macro yazabilir misiniz?

teşekkürlerimi sunarım.

Kontrol edermisiniz

Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim LastRow As Long

' A sütununda yapılan değişiklikleri izleyin
Set KeyCells = Intersect(Target, Me.Columns("A"))

' Eğer A sütununda bir değişiklik varsa
If Not KeyCells Is Nothing Then
' Son girilen veriyi sakla
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
LastValue = Cells(LastRow, "A").Value

' A sütunundaki diğer tüm verileri sil
Columns("A:A").ClearContents

' Son girilen veriyi tekrar yaz
Cells(1, "A").Value = LastValue
End If
End Sub

 

[teonet]

Kontrol edermisiniz

Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim LastRow As Long

' A sütununda yapılan değişiklikleri izleyin
Set KeyCells = Intersect(Target, Me.Columns("A"))

' Eğer A sütununda bir değişiklik varsa
If Not KeyCells Is Nothing Then
' Son girilen veriyi sakla
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
LastValue = Cells(LastRow, "A").Value

' A sütunundaki diğer tüm verileri sil
Columns("A:A").ClearContents

' Son girilen veriyi tekrar yaz
Cells(1, "A").Value = LastValue
End If
End Sub

Merhaba Sayın Zehirle,
öncelikle cevap için teşekkür ederim, istediğim sonucu veriyor fakat çok uzun sürüyor. 1 ile 1000 satır arası sınırlasak daha hızlı olur mu acaba saygılar.

 

[zehirlee]

Merhaba Sayın Zehirle,
öncelikle cevap için teşekkür ederim, istediğim sonucu veriyor fakat çok uzun sürüyor. 1 ile 1000 satır arası sınırlasak daha hızlı olur mu acaba saygılar.

kontrol ediniz

Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim LastRow As Long

' 1 ile 1000 arasındaki satırlardaki A sütununda yapılan değişiklikleri izleyin
Set KeyCells = Intersect(Target, Me.Range("A1:A1000"))

' Eğer 1 ile 1000 arasındaki satırlardaki A sütununda bir değişiklik varsa
If Not KeyCells Is Nothing Then
' Son girilen veriyi sakla
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
LastValue = Cells(LastRow, "A").Value

' A sütunundaki diğer tüm verileri sil
Columns("A:A").ClearContents

' Son girilen veriyi tekrar yaz
Cells(1, "A").Value = LastValue
End If
End Sub

 

[teonet]

kontrol ediniz

Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim LastRow As Long

' 1 ile 1000 arasındaki satırlardaki A sütununda yapılan değişiklikleri izleyin
Set KeyCells = Intersect(Target, Me.Range("A1:A1000"))

' Eğer 1 ile 1000 arasındaki satırlardaki A sütununda bir değişiklik varsa
If Not KeyCells Is Nothing Then
' Son girilen veriyi sakla
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
LastValue = Cells(LastRow, "A").Value

' A sütunundaki diğer tüm verileri sil
Columns("A:A").ClearContents

' Son girilen veriyi tekrar yaz
Cells(1, "A").Value = LastValue
End If
End Sub

Bu sefer süre 20 saniyeye kadar kısaldı. işlem bittiğinde ecel dosyalarını kapatıyor.

 

[zehirlee]

Birde bunu denermisiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim LastRow As Long
Dim SheetName As String
Dim CloseTime As Date

' 1 ile 1000 arasındaki satırlardaki A sütununda yapılan değişiklikleri izleyin
Set KeyCells = Intersect(Target, Me.Range("A1:A1000"))

' Eğer 1 ile 1000 arasındaki satırlardaki A sütununda bir değişiklik varsa
If Not KeyCells Is Nothing Then
' Sayfa adını E1 hücresinden al
SheetName = Range("E1").Value

' Son girilen veriyi sakla
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
LastValue = Cells(LastRow, "A").Value

' A sütunundaki diğer tüm verileri sil
Columns("A:A").ClearContents

' Son girilen veriyi tekrar yaz
Cells(1, "A").Value = LastValue

' Zamanlayıcıyı iptal et
On Error Resume Next
Application.OnTime EarliestTime:=CloseTime, Procedure:="CloseExcel", Schedule:=False
On Error GoTo 0

MsgBox "Sayfa adı: " & SheetName & vbCrLf & "Excel dosyası kapatılmayacak."
End If
End Sub

 

[muhasebeciyiz]

Düzenleme yapıldı.Lütfen deneyiniz

 

[teonet]

Düzenleme yapıldı.Lütfen deneyiniz

Merhaba, kodları yine aktif edemedim. otomatik çalışmıyor. değerli cevabınız için teşekkür ederim.

 

[teonet]

Birde bunu denermisiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Dim LastRow As Long
Dim SheetName As String
Dim CloseTime As Date

' 1 ile 1000 arasındaki satırlardaki A sütununda yapılan değişiklikleri izleyin
Set KeyCells = Intersect(Target, Me.Range("A1:A1000"))

' Eğer 1 ile 1000 arasındaki satırlardaki A sütununda bir değişiklik varsa
If Not KeyCells Is Nothing Then
' Sayfa adını E1 hücresinden al
SheetName = Range("E1").Value

' Son girilen veriyi sakla
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
LastValue = Cells(LastRow, "A").Value

' A sütunundaki diğer tüm verileri sil
Columns("A:A").ClearContents

' Son girilen veriyi tekrar yaz
Cells(1, "A").Value = LastValue

' Zamanlayıcıyı iptal et
On Error Resume Next
Application.OnTime EarliestTime:=CloseTime, Procedure:="CloseExcel", Schedule:=False
On Error GoTo 0

MsgBox "Sayfa adı: " & SheetName & vbCrLf & "Excel dosyası kapatılmayacak."
End If
End Sub

Merhaba, denedim. bu da çok uzun süre çalışıyor. desteğin için teşekkür ederim.

 

[ÖmerBey]

Merhaba,
Kodda yavaş çalışmayı gerektirecek bir durum yok gibi, sizin dosyanızdaki formüller ve hesaplamalar kaynaklı bir yavaşlama söz konusu olabilir.
Aşağıdaki yapıyı deneyiniz.

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Intersect(ActiveSheet.UsedRange, Columns("A:A")).ClearContents

Cells(1, "A").Value = LastValue
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True