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
|