Çoklu ya da seçerek kayıt silme

meleklerim · Dün 13:16 da

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

pitchoute · Dün 13:36 da

Merhaba,

1)Aynı ID'ye Sahip Tüm Satırları Silmek:

Kod:

Private Sub KAYITSIL()
    Dim ws As Worksheet
    Dim aranan As Variant
    Dim sonSatir As Long
   
    Set ws = Worksheets("data")
   
    If ID.Value <> "" Then
        aranan = ID.Value
        Application.ScreenUpdating = False
       
        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
       
        Application.ScreenUpdating = True
    End If
End Sub

2) ListView'da Çoklu Seçim ile Satırları Silmek:

Kod:

Private Sub KAYITSIL()
    Dim ws As Worksheet
    Dim aranan As Variant
    Dim sonSatir As Long
    Dim i As Integer
    Dim seciliIDler As New Collection
   
    Set ws = Worksheets("data")
  
    For i = 1 To ListView1.ListItems.Count
        If ListView1.ListItems(i).Checked Then
            seciliIDler.Add ListView1.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

İyi çalışmalar.

meleklerim · Dün 14:34 da

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

pitchoute · Dün 14:49 da

Şöyle dener misiniz;

Kod:

Private Sub KAYITSIL()
    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).Selected 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 · Dün 16:32 da

.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ş

pitchoute · Dün 16:40 da

Bu şekilde deneyebilir misiniz;

Kod:

Private Sub KAYITSIL()
    Dim ws As Worksheet
    Dim aranan As Variant
    Dim sonSatir As Long
    Dim i As Long
    Dim seciliIDler As New Collection
    Dim rngToDelete As Range
  
    Set ws = Worksheets("ODEME")
 
    For i = 1 To ODELIST.ListItems.Count
        If ODELIST.ListItems(i).Selected 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
          
            If ws.AutoFilterMode Then
                ws.AutoFilterMode = False
            End If
          
            ws.Range("A1:A" & sonSatir).AutoFilter Field:=1, Criteria1:=aranan
          
            With ws
                On Error Resume Next
                Set rngToDelete = .Range("A2:A" & sonSatir).SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
              
                If Not rngToDelete Is Nothing Then
                    rngToDelete.EntireRow.Delete
                    Set rngToDelete = Nothing
                End If
              
                .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 · Dün 16:51 da

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.

pitchoute · Dün 17:31 da

Helal olsun hocam, hiç sorun yok. Detaylı ve sizin üstünde düzenleme yapabileceğiniz şekilde paylaşıyorum, belirttiğim kısımlarda eğer farklılık varsa lütfen düzenleme yapın.

Kod:

Private Sub KAYITSIL()
    Dim ws As Worksheet
    Dim arananID As Variant
    Dim gas As Long
    Dim i As Long
    Dim selectedIDs As New Collection
    Dim item As ListItem
    
    ' "data" sayfasını tanımlıyoruz
    Set ws = Worksheets("data")
    
    If ListView1.ListItems.Count = 0 Then
        MsgBox "ListView boş.", vbExclamation
        Exit Sub
    End If
    
    For i = 1 To ListView1.ListItems.Count
        If ListView1.ListItems(i).Checked Then ' Checkbox kullanılıyorsa
            selectedIDs.Add ListView1.ListItems(i).Text ' ID'nin ilk sütunda olduğunu varsayıyoruz
        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
    
    Dim rowsToDelete As New Collection
    Dim foundCell As Range
    Dim firstAddress As String
    
    For Each arananID In selectedIDs
        ' Aranan ID'nin bulunup bulunmadığını kontrol ediyoruz
        With ws.Range("A:A") ' ID'lerin bulunduğu sütun "A" olduğunu varsayıyoruz
            Set foundCell = .Find(What:=arananID, LookIn:=xlValues, LookAt:=xlWhole)
            If Not foundCell Is Nothing Then
                firstAddress = foundCell.Address
                Do
                    rowsToDelete.Add foundCell.Row
                    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
    
    Dim uniqueRows As New Collection
    Dim rowNum As Variant
    On Error Resume Next ' Aynı anahtarla ekleme hatalarını göz ardı ediyoruz
    For Each rowNum In rowsToDelete
        uniqueRows.Add rowNum, CStr(rowNum)
    Next rowNum
    On Error GoTo 0
    
    Dim rowArray() As Variant
    Dim index As Long
    
    ReDim rowArray(1 To uniqueRows.Count)
    index = 1
    For Each rowNum In uniqueRows
        rowArray(index) = rowNum
        index = index + 1
    Next rowNum
    
    Dim swapped As Boolean
    Do
        swapped = False
        For i = LBound(rowArray) To UBound(rowArray) - 1
            If rowArray(i) < rowArray(i + 1) Then
                Dim temp As Variant
                temp = rowArray(i)
                rowArray(i) = rowArray(i + 1)
                rowArray(i + 1) = temp
                swapped = True
            End If
        Next i
    Loop While swapped
    
    For i = LBound(rowArray) To UBound(rowArray)
        ws.Rows(rowArray(i)).Delete
    Next i
    
    Application.ScreenUpdating = True
    
    MsgBox "Seçili öğeler silindi.", vbInformation
End Sub

meleklerim · Dün 17:51 da

hocam son gönderdiğin seçili olan kaç tane olursa olsun tümünü siliyor

pitchoute · Dün 19:26 da

Hocam şöyle dener misiniz;

Kod:

Private Sub KAYITSIL()
    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
    
    ' "data" sayfasını tanımlıyoruz
    Set ws = Worksheets("data")
    
    Set selectedIDs = New Collection
    For i = 1 To ListView1.ListItems.Count
        If ListView1.ListItems(i).Checked Then ' Checkbox kullanılıyorsa
            selectedIDs.Add ListView1.ListItems(i).Text ' ID'nin ilk sütunda olduğunu varsayıyoruz
        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") ' ID'lerin bulunduğu sütun A olduğunu varsayıyoruz
            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) ' Aynı satırı tekrar eklememek için
                    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
        
        ' ListView'i güncellemeniz gerekiyorsa burada yapabilirsiniz
        ' Örneğin:
        ' Call ListViewVerileriniYenile
        
        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

meleklerim · Dün 20:14 da

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