Need a macro to delete rows regardless of punctuation

Sub replacement()
Application.ScreenUpdating = False
Dim LOTitle As ListObject
Set LOTitle = Sheet1.ListObjects("Table1")
Dim Arr1, Arr2(), x As Long, y As Long
On Error Resume Next
Arr1 = Application.Transpose(LOTitle.ListColumns(1).DataBodyRange)
ReDim Arr2(UBound(Arr1))
For x = LBound(Arr1) To UBound(Arr1)
'If character in string is not a number or letter the erase it.
For y = Len(Arr1(x)) To 1 Step -1


If Not (Asc(UCase(Mid(Arr1(x), y, 1))) > 64 And Asc(UCase(Mid(Arr1(x), y, 1))) < 91) And _
Not (Asc(Mid(Arr1(x), y, 1)) > 47 And Asc(Mid(Arr1(x), y, 1)) < 58) Then _
Arr1(x) = Replace(Arr1(x), CStr(Mid(Arr1(x), y, 1)), "")
Next y
Next x
'if members of the array are repeated erase all but first iteration.
For x = 1 To UBound(Arr1)
For y = 1 To UBound(Arr1)
If x = y Then GoTo nxtY
If Arr1(x) = Arr1(y) Then Arr1(y) = vbNullString
nxtY:
Next y
Next x
'if arr member not empty copy to new list.
For x = 1 To UBound(Arr1)
If Arr1(x) <> vbNullString Then
y = Sheet1.Cells(Rows.Count, 5).End(xlUp).Row
Sheet1.Cells(y + 1, 5).Value2 = LOTitle.DataBodyRange(x, 1).Value2
Sheet1.Cells(y + 1, 6).Value2 = LOTitle.DataBodyRange(x, 2).Value2
Sheet1.Cells(y + 1, 7).Value2 = LOTitle.DataBodyRange(x, 3).Value2
End If
Next x
Application.ScreenUpdating = True
End Sub