Auto Move Row Help

[Sid10]

Hi Guys im new here been really struggling to sort this

Basically i have 3 spreadsheets

spread sheet 1 = Temp
spread sheet 2 = Dead
spread sheet 3 = Alive

When type "a" the whole line from temp moves to "F" to Alive
When type "d" the whole line from temp moves to "F" to Dead

Worked perfect

However i tried to be clever and setup a COUNTIF that shows if i already have duplicate Data on the Dead page in Column B which reflects on B in TEMP

This works however it takes so long im guessing as the Column G has the COUNTIF formula its taking ages to process

I see a few options here:

either theres a way to move the whole row minus the COUNTIF Formula
move the whole row starting at B rather than A (A Could contain the COUNTIF)
or last one i only move certain columns rather than the whole row

Ive spent lots of time attempting to fix this but im struggling so i would really appreciate some help


=============================================================================================================================


Here is the code im using below

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim xRg As Range
Dim xCell As Range
Dim xRRg1 As Range
Dim xRRg2 As Range
Dim xDWS As Worksheet
Dim xLWS As Worksheet
Dim xEWS As Worksheet
Dim xDR, xLR, xER As Long
Dim xDC As Long
Dim K As Long
Dim xC1 As Long
Dim xFNum As Long
Set xDWS = Worksheets("Temp")
Set xLWS = Worksheets("Alive") 'Alive
Set xEWS = Worksheets("Dead") 'Dead
xDR = xDWS.UsedRange.Rows.Count
xLR = xLWS.UsedRange.Rows.Count
xER = xEWS.UsedRange.Rows.Count
xDC = xDWS.UsedRange.Columns.Count
If xLR = 1 Then
If Application.WorksheetFunction.CountA(xLWS.UsedRange) = 0 Then xLR = 0
End If
If xER = 1 Then
If Application.WorksheetFunction.CountA(xEWS.UsedRange) = 0 Then xER = 0
End If
Set xRg = xDWS.Range("A1:E" & xDR)
On Error Resume Next
Application.ScreenUpdating = False
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = "a" Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xLWS.Range("A" & xLR + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xLR = xLR + 1
ElseIf CStr(xRg(K).Value) = "d" Then
Set xRRg1 = xRg(K).EntireRow
Set xRRg2 = xEWS.Range("A" & xER + 1).EntireRow
For xFNum = 1 To xDC
xRRg2.Value = xRRg1.Value
Next xFNum
xRg(K).EntireRow.Delete
xER = xER + 1
End If
Next K
Application.ScreenUpdating = True
End Sub

Hope it makes sense

Thanks