大侠们，帮忙写个删除重复项的程序呗

hasyh2008

Sub TQ()
    Dim X%, K%
    Dim str As String
    K = 1
    For X = 2 To Sheet1.Cells(Rows.Count, 2).End(xlUp).Row
        If Application.WorksheetFunction.CountIf(Sheet1.Range("B2:B" & X), Sheet1.Cells(X, 2)) = 1 Then
            K = K + 1
            Sheet1.Cells(X, 2).Copy Sheet2.Cells(K, 1)
        ElseIf Application.WorksheetFunction.CountIf(Sheet1.Range("B2:B" & X), Sheet1.Cells(X, 2)) = 2 Then
            str = str & Cells(X, 2).Value & ","
        End If
    Next X
    Sheet2.Range("A1") = str
End Sub

hasyh2008

Sub TQ()
    Dim X%, K%
    Dim str As String
    K = 1
    With Sheet1
    For X = 2 To Sheet1.Cells(Rows.Count, 2).End(xlUp).Row
        If Application.WorksheetFunction.CountIf(.Range("B2:B" & X), .Cells(X, 2)) = 1 Then
            K = K + 1
            .Cells(X, 2).Copy Sheet2.Cells(K, 1)
        ElseIf Application.WorksheetFunction.CountIf(.Range("B2:B" & X), .Cells(X, 2)) = 2 Then
            str = str & Cells(X, 2).Value & ","
        End If
    Next X
    End With
    Sheet2.Range("A1") = str
End Sub

hasyh2008

请试下！！！