Diğer sayfada olmayanlar silinsin

[tahsinanarat]

Ekli örnek dosyamda iki ayrı sekmem var, Arşiv ve Personel sayfaları, Personel sayfasında Aktif çalışanlar, Arşiv sayfasında ise hem aktif hemde işten ayrılanların sicil ve isimleri var.

Arşiv sayfasında; personel sayfasında olan sicillerin haricindeki tüm satırlar silinmesini istiyorum. Örnek dosyamda isimleri tomson1,tomson2.......vs olanların (sicil sutunları baz alınarak) tüm satırlarının silinmesi gerekiyor.

Yardımlarınız için şimdiden çok teşekkür ediyorum.

 

[Necdet]

Merhaba,
Aşağıdaki kodları dosyanızın bir yedeğini aldıktan sonra deneyiniz.

Sub Arsivden_Sil()

    Dim i   As Long, _
        Adt As Integer, _
        c   As Range
    
    For i = Sayfa4.Cells(Rows.Count, "B").End(3).Row To 6 Step -1
        Set c = Sayfa1.Range("A:A").Find(Sayfa4.Cells(i, "B"), LookIn:=xlValues, LookAt:=xlWhole)
        If c Is Nothing Then
            Adt = Adt + 1
            Debug.Print Sayfa4.Cells(i, "C")
            Sayfa4.Rows(i).Delete
        End If
    Next i
    
    If Adt = 0 Then
        MsgBox "Eşleşen Kayıt Bulunmadı...."
    Else
        MsgBox Adt & " Adet Kayıt Silindi...... Silinen Personelin Listesi VBA'da Immediate Window  (Ctrl+G) Ekranında Listelenmiştir  "
    End If
    
End Sub

 

[tahsinanarat]

Sn. @Necdet hocam emeğiniz için çok teşekkür ediyorum, bende yabancı siteden araştırma yaparken bulduğum kodları ekliyorum altarnetif olsun.

Sub Del_Rws()
  Dim d As Object
  Dim a As Variant, b As Variant, itm As Variant
  Dim nc As Long, i As Long, k As Long
 
  Set d = CreateObject("Scripting.Dictionary")
  a = Sheets("Personel").Range("A2", Sheets("Personel").Range("A" & Rows.Count).End(xlUp)).Value
  For Each itm In a
    d(itm) = 1
  Next itm
  With Sheets("Arsiv")
    a = .Range("b6", .Range("b" & Rows.Count).End(xlUp)).Value
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
      If Not d.exists(a(i, 1)) Then
        k = k + 1
        b(i, 1) = 1
      End If
    Next i
    If k > 0 Then
      Application.ScreenUpdating = False
      nc = .Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
      With .Range("A6").Resize(UBound(a), nc)
        .Columns(nc).Value = b
        .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
        .Resize(k).EntireRow.Delete
      End With
      Application.ScreenUpdating = True
    End If
  End With
End Sub