Çoklu ya da seçerek kayıt silme

meleklerim

Altın Üye
Katılım
2 Ekim 2013
Mesajlar
347
Excel Vers. ve Dili
ofis 2019 türkçe
windows 10 pro türkçe
Altın Üyelik Bitiş Tarihi
23-07-2025
aşağıdaki makro ile data sayfasında Listwiev da ID ile belirlediğim satırı silebiliyorum.
Ancak aynı ID ye sahip satırların ya da listwiev da çoklu chexkbox seçimi ile silmek için nasıl bir kod olmalı?

yardımlarınız için şimdiden teşekkürler

Private Sub KAYITSIL()
Worksheets("data").Select
Dim gas, aranan As Variant
If ID <> "" Then
aranan = ID.Value
Range("A:A").Find(aranan).Select
gas = ActiveCell.Row

Rows(gas).Delete
End Sub
 

meleklerim

Altın Üye
Katılım
2 Ekim 2013
Mesajlar
347
Excel Vers. ve Dili
ofis 2019 türkçe
windows 10 pro türkçe
Altın Üyelik Bitiş Tarihi
23-07-2025
aynı ID ye sahip kayıtların silinmesi çalışıyor. Çok çok çok teşekkür ederim.
Fakat çoklu seçimde seçmeme rağmen listeden seçiniz diyor.
Sayfamın adı ODEME
Listemin adı ODELIST

yerlerine koydum ama nerede hata var bulamadım.
Listwiev da ayrıca bir ayar mı yapmam lazım (halen Multiselect ve fulrow select seçili)

Private Sub ODESIL_Click()

Dim ws As Worksheet
Dim aranan As Variant
Dim sonSatir As Long
Dim i As Integer
Dim seciliIDler As New Collection

Set ws = Worksheets("ODEME")

For i = 1 To ODELIST.ListItems.Count
If ODELIST.ListItems(i).Checked Then
seciliIDler.Add ODELIST.ListItems(i).SubItems(1) ' ID değerini alıyoruz
End If
Next i

If seciliIDler.Count > 0 Then
Application.ScreenUpdating = False

For Each aranan In seciliIDler
sonSatir = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

ws.Range("A1:A" & sonSatir).AutoFilter Field:=1, Criteria1:=aranan

With ws
.Range("A2:A" & sonSatir).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilterMode = False
End With
Next aranan

Application.ScreenUpdating = True
Else
MsgBox "Lütfen silmek istediğiniz kayıtları seçin.", vbInformation
End If
End Sub
 

meleklerim

Altın Üye
Katılım
2 Ekim 2013
Mesajlar
347
Excel Vers. ve Dili
ofis 2019 türkçe
windows 10 pro türkçe
Altın Üyelik Bitiş Tarihi
23-07-2025
.Range("A2:A" & sonSatir).SpecialCells(xlCellTypeVisible).EntireRow.Delete

denedim ama
şu satırda hata veriyor. hiçbir hücre seçilmedi diyor. ODEME sayfasının A sütunu filtreli kalıyor. Bir de sütun başlıkları silinmiş
 

meleklerim

Altın Üye
Katılım
2 Ekim 2013
Mesajlar
347
Excel Vers. ve Dili
ofis 2019 türkçe
windows 10 pro türkçe
Altın Üyelik Bitiş Tarihi
23-07-2025
malesef bu hiç bir harekete sebep olmadı. Normalde hiçbir satırı seçmeden sil dediğimde
"Lütfen silmek istediğiniz kayıtları seçin.", mesajı bile çıkmadı
sizi de yoruyorum hakkınızı helal edin.
 

meleklerim

Altın Üye
Katılım
2 Ekim 2013
Mesajlar
347
Excel Vers. ve Dili
ofis 2019 türkçe
windows 10 pro türkçe
Altın Üyelik Bitiş Tarihi
23-07-2025
hocam son gönderdiğin seçili olan kaç tane olursa olsun tümünü siliyor
 

meleklerim

Altın Üye
Katılım
2 Ekim 2013
Mesajlar
347
Excel Vers. ve Dili
ofis 2019 türkçe
windows 10 pro türkçe
Altın Üyelik Bitiş Tarihi
23-07-2025
tüm listeyi olduğu gibi başlıklarını bile siliyor malesef. Sayfa tertemiz oluyor :)

Private Sub COKODESIL()
Dim ws As Worksheet
Dim arananID As Variant
Dim i As Long
Dim selectedIDs As Collection
Dim foundCell As Range
Dim firstAddress As String
Dim IDsToDelete As Collection


Set ws = Worksheets("ODEME")

Set selectedIDs = New Collection
For i = 1 To ODELIST.ListItems.Count
If ODELIST.ListItems(i).Checked Then
selectedIDs.Add ODELIST.ListItems(i).Text
End If
Next i

If selectedIDs.Count = 0 Then
MsgBox "Lütfen silmek istediğiniz öğeleri seçin.", vbInformation
Exit Sub
End If

Application.ScreenUpdating = False

Set IDsToDelete = New Collection

For Each arananID In selectedIDs
With ws.Range("A:A")
Set foundCell = .Find(What:=arananID, LookIn:=xlValues, LookAt:=xlWhole)
If Not foundCell Is Nothing Then
firstAddress = foundCell.Address
Do
On Error Resume Next
IDsToDelete.Add foundCell.Row, CStr(foundCell.Row)
On Error GoTo 0
Set foundCell = .FindNext(foundCell)
Loop While Not foundCell Is Nothing And foundCell.Address <> firstAddress
Else
MsgBox "ID " & arananID & " bulunamadı.", vbExclamation
End If
End With
Next arananID

If IDsToDelete.Count > 0 Then
Dim rowNumbers() As Long
Dim index As Long

ReDim rowNumbers(1 To IDsToDelete.Count)
index = 1
For Each arananID In IDsToDelete
rowNumbers(index) = arananID
index = index + 1
Next arananID

Dim j As Long, temp As Long
For i = LBound(rowNumbers) To UBound(rowNumbers) - 1
For j = i + 1 To UBound(rowNumbers)
If rowNumbers(i) < rowNumbers(j) Then
temp = rowNumbers(i)
rowNumbers(i) = rowNumbers(j)
rowNumbers(j) = temp
End If
Next j
Next i

For i = 1 To UBound(rowNumbers)
ws.Rows(rowNumbers(i)).Delete
Next i

Application.ScreenUpdating = True

Call ODELISTELE
MsgBox "Seçili kayıtlar başarıyla silindi.", vbInformation
Else
Application.ScreenUpdating = True
MsgBox "Belirtilen ID'lere sahip kayıtlar bulunamadı.", vbExclamation
End If
End Sub
 
Son düzenleme:
Üst