vba for keeping first 4 characters and removing duplicates

[psrs0810]

In a ws labeled "Table Build" I need to clean up some of my data. In column B, I want the first for digits and then remove any duplicates. if duplicates are found, to delete the row.







EntityID

DeptNum





11

1011





11

1011A





11

1011B





11

1011C





11

10500





11

1110





11

1110A





11

1110B





11

1110C





11

1110D





11

1115





11

1119

[mana]

Option Explicit


Sub test()
Dim c As Range
Dim r As Range

For Each c In Range("B2", Range("B" & Rows.Count).End(xlUp))
If Not IsNumeric(c) Then
If r Is Nothing Then
Set r = c
Else
Set r = Union(r, c)
End If
End If
Next
If Not r Is Nothing Then r.EntireRow.Delete

End Sub


マナ

[SamT]

Try this. It's Compiled, but not tested
Option Explicit

Sub SamT()
Dim rngDeptNum As Range
Dim arrDeptNum, arrNewDeptNum
Dim i As Long, j As Long, k As Long

With Sheets("Table Build")
'Set the working Range
Set rngDeptNum = Range(Cells(2, "A"), Cells(Rows.Count, "B").End(xlUp))
'Put the Working Rnge into an array
arrDeptNum = rngDeptNum

'Left 4 Characters only
For i = LBound(arrDeptNum) To UBound(arrDeptNum)
arrDeptNum(i) = Left(arrDeptNum(i), 4)
Next

ReDim arrNewDeptNum(LBound(arrDeptNum, 1) To UBound(arrDeptNum, 1), 2)
k = LBound(arrDeptNum, 1)

'Clear Dupes
For i = LBound(arrDeptNum, 1) To UBound(arrDeptNum, 1)
For j = LBound(arrDeptNum, 1) To UBound(arrDeptNum, 1)
If j = i Then GoTo jNext 'Don't clear this one
If arrDeptNum(i, 2) = arrDeptNum(j, 2) Then arrDeptNum(j, 2) = ""
jNext:
Next j
Next i

'Load New Dept Nums Without Dupes
For i = LBound(arrDeptNum, 1) To UBound(arrDeptNum, 1)
If arrDeptNum(i, 2) <> "" Then
arrNewDeptNum(k) = arrDeptNum(i)
k = k + 1
End If
Next i

'Put the new values into the Table
rngDeptNum = arrNewDeptNum
End With
End Sub