☰

删除重复的行并保留特定列数据的重复项

tag-icon • tag-icon microsoft-excel
删除重复的行并保留特定列数据的重复项

我需要根据主管是否在列表中删除重复的数据，但如果两个重复的数据都为“NULL”，那么我仍然需要保留一个。我该怎么做？请参阅图片作为参考。

在此处输入图片描述

答案1

尝试此代码并让我知道它是否满足您的要求，您需要将 sheet1 更改为包含数据的工作表，将 sheet2 更改为空白工作表。将数字 3 (myuniqueID) 和 6 (MySupervisor) 更改为包含该信息的列。它是否假设有一列具有某种形式的唯一 ID 来识别重复项？

Option Base 1
Sub copydupeswcrit()
'This sub works through data in wsF and copies any duplicates to wsT
    Application.ScreenUpdating = False
    Dim wsF As Worksheet: Set wsF = Sheet1
    Dim wsT As Worksheet: Set wsT = Sheet2
    Dim x As Long, y As Long, i As Long, t As Long, q As Long, n As Long, MySupervisor As Long, MyUniqueID As Long
    Dim myarr1 As Variant, MyxArr As Variant, myarr3 As Variant
    i = 1
    MyUniqueID = 3
    MySupervisor = 6
    'create array from sheet
    myarr1 = wsF.Range("A1").CurrentRegion
    ReDim MyxArr(UBound(myarr1, 1)) ' array to check if unique ID already checked
    'Prepare array to receive data
    ReDim myarr3(UBound(myarr1, 1), UBound(myarr1, 2))
    For x = LBound(myarr1, 1) To UBound(myarr1, 1)                      'scout through array
        For y = LBound(myarr1, 1) To UBound(myarr1, 1)
            If x = y Then GoTo MyNxtY                                   'if looking at the same line move to next y
            If myarr1(x, MyUniqueID) = myarr1(y, MyUniqueID) Then                         'if ID numbers match do this
                For n = LBound(MyxArr) To UBound(MyxArr)                    'exit loop if ID already checked
                    If myarr1(x, MyUniqueID) = MyxArr(n) Then GoTo MyNxtY
                Next n
                If myarr1(x, MySupervisor) <> vbNullString Then    'check if supervisor column (5 or E) contains information
                    For t = 1 To UBound(myarr1, 2)      'copies first line to new array if supervisor detail present, else copies second line
                        myarr3(i, t) = myarr1(x, t)
                    Next t
                Else
                    For t = 1 To UBound(myarr1, 2)      'copy new line to array3
                        myarr3(i, t) = myarr1(y, t)
                    Next t
                End If
                GoTo MyNxtX
            End If
MyNxtY:
        Next y
    For t = 1 To UBound(myarr1, 2)
        myarr3(i, t) = myarr1(x, t)
    Next t
i = i + 1
MyNxtX:
        MyxArr(x) = myarr1(x, MyUniqueID) ' creates checking array
    Next x
wsT.Range("A1").Resize(UBound(myarr3, 1), UBound(myarr3, 2)) = myarr3 ' pastes array to new sheet
Application.ScreenUpdating = True
End Sub

相关内容