DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
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
Kontrol edermisinizMerhaba
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
kontrol edinizMerhaba 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.
Bu sefer süre 20 saniyeye kadar kısaldı. işlem bittiğinde ecel dosyalarını kapatıyor.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
Merhaba, kodları yine aktif edemedim. otomatik çalışmıyor. değerli cevabınız için teşekkür ederim.Düzenleme yapıldı.Lütfen deneyiniz
Merhaba, denedim. bu da çok uzun süre çalışıyor. desteğin için teşekkür ederim.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
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Intersect(ActiveSheet.UsedRange, Columns("A:A")).ClearContents
Cells(1, "A").Value = LastValue
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True