Question : Excel Keep/Delete Records in Sheet1 that are in Sheet2

Please offer how I may create a new Sheet3 for the following:

1. Keep records in Sheet1 that are also in Sheet2 (Sheet2 is a subset of Sheet1 - and I want to truncate Sheet1 to only the records in Sheet2) - the result in Sheet3 will be an intersection of Sheet1 and Sheet2

2 Delete records in Sheet1 that are in Sheet2(again, Sheet2 is a subset of Sheet1 - I want to remove all records in Sheet1 that are found in Sheet2) - Sheet3 will be an outer join of Sheet1 and Sheet2, with records only found in Sheet1.

In both cases, a new Sheet3 will be created, based upon the Keeping/Deletion from Sheet1 when compared to Sheet2 - please assume the column is labeled A.

Thanks.

Thanks.

Answer : Excel Keep/Delete Records in Sheet1 that are in Sheet2

Okay i assumed its the header name that is Primary name and its row-1 of your both the sheets, Plus this will automatically create sheet-3 in your workbook and this for unique list...

for common list...just change this line...

If Application.WorksheetFunction.CountIf(rng, c.Value) = 0 Then

to this...

If Application.WorksheetFunction.CountIf(rng, c.Value) > 0 Then

Saurabh...

                       
         
           
             1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:

           
           
             Sub move()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim i As Long, rng As Range
    Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
    Dim r As Range, c As Range, f As Range
    Dim y As Long, k As Long
    On Error Resume Next
    Sheets("Sheet3").delete
 Sheets.Add After:=Sheets(Sheets.Count)
 ActiveSheet.Name = "Sheet3"
 
    Set ws = Sheets("Sheet1")
    Set ws1 = Sheets("Sheet2")
    Set ws2 = Sheets("Sheet3")
 
 Set f = ws.Rows(1).Find(What:="Primary Name", After:=Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
k = f.Column
 
Set r = ws.Range(Cells(1, k).Address & ":" & Cells(ws.Cells(65536, k).End(xlUp).Row, k).Address)
 
 Set f = ws1.Rows(1).Find(What:="Primary Name", After:=Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
y = f.Column
 
 
Set rng = ws1.Range(Cells(1, y).Address & ":" & Cells(ws1.Cells(65536, y).End(xlUp).Row, y).Address)
 
    For Each c In r
        If Application.WorksheetFunction.CountIf(rng, c.Value) = 0 Then
            c.EntireRow.Copy ws2.Range("A" & ws2.Cells(65536, k).End(xlUp).Row + 1)
 
        End If
    Next c
 
 
    MsgBox "Done"
 
    Application.ScreenUpdating = True
 Application.DisplayAlerts = True
End Sub
           
         

Open in New Window

Select All