Sub unique()
Dim xlApp, xlBook, xlSheet
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlBook = xlApp.Workbooks.Open("表格8.xls")
Set xlSheet = xlBook.Worksheets(77)

Dim arr, i, j, k As Integer 
arr = Range("B2:B" & Cells(Rows.Count, 2).End(x1Up).Row).Value2 '将B列的值赋给数组arr

For i = UBound(arr) To LBound(arr) Step -1 '从最后一个元素开始循环比较，发现重复元素就删除

    For j = LBound(arr) To i - 1 '从当前循环位开始，与之前所有元素进行比较

        If arr(i) = arr(j) Then '如果发现重复元素，则将该重复元素以及之后的所有元素都向前一位（覆盖）

            For k=i To UBound(arr)-1  

                arr (k)=arr (k+1 )  

            Next  

        End If  

    Next  

Next  

Range("B2").Resize (UBound (arr)+1 )=Application .Transpose (arr )'将新的数据写回Excel中。
End Sub