Delete duplicate entries in a given row

问题

I want to delete the duplicates in each row, such that there should be no "holes" in the row. What I have is:

Col A    Col B   Col C    Col D    Col E   Col F   Col G
A         B        C        D        A       B       A
J         I        K        J        I       K       I
B         A        B        J        I       K       L

up to 40k rows.
Output required:

Col A    Col B   Col C    Col D    Col E   Col F   Col G
A         B        C        D       
J         I        K        
B         A        J        I       K       L

回答1:

Make sure that the columns to the right of your source data are blank. The output is going to go there.

Place this routine in a standard code module and run it:

Public Sub CullDistinct()
    Dim rSrc As Range, lRws&, lCls&, lOut&, sOut$, sMn1$, sRow1$
    Set rSrc = [a1].CurrentRegion
    sRow1 = rSrc.Resize(1).Address(0, 1)
    lRws = rSrc.Rows.Count
    lCls = rSrc.Columns.Count
    lOut = lCls + 2
    sOut = Split(Cells(, lOut).Address, "$")(1)
    sMn1 = Split(Cells(, lOut - 1).Address, "$")(1) & 1: sMn1 = sMn1 & ":" & sMn1
    With Range(sOut & 1)
        .FormulaArray = "=IFERROR(INDEX(" & sRow1 & ",MATCH(,COUNTIF($" & sMn1 & "," & sRow1 & "),)),"""")"
        .Copy .Offset(, 1).Resize(, lCls - 1)
        .Resize(, lCls).Copy .Offset(1).Resize(lRws - 1)
        With .Resize(lRws, lCls): .Value = .Value: End With
    End With
End Sub

回答2:

I suggest iterating over each row in the range, extracting the values, generating the unique set, and repaste into the row.

The following function takes an array of values and returns the unique values in the array, using a Scripting.Dictionary. Add a reference (Tools -> References...) to the Microsoft Scripting Runtime.

Function Unique(values As Variant) As Variant()
    'Put all the values as keys into a dictionary
    Dim dict As New Scripting.Dictionary, val As Variant
    For Each val In values
        dict(val) = 1
    Next
    Unique = dict.Keys
End Function

Then you can do the following:

Dim rng As Range, row As Range
Set rng = ActiveSheet.UsedRange
For Each row In rng.Rows
    Dim values() As Variant 'We need this to extract the values from the range, and to avoid passing in the range itself
    values = row
    Dim newValues() As Variant
    newValues = Unique(values)
    ReDim Preserve newValues(UBound(values, 2)) 'without this, the array will be smaller than the row, and Excel will fill the unmatched cells with #N/A
    row = newValues
Next

来源：https://stackoverflow.com/questions/32294632/delete-duplicate-entries-in-a-given-row