Блог

Я пытаюсь скопировать список, удалить дубликаты и вставить его в другое место, но по какой-то причине он сохраняет две из трех копий 1-см. Прилагаемое. Не знаю, зачем он это делает, любая помощь была бы очень признательна.

Расширенный фильтр предполагает, что верхняя ячейка является заголовком, и не считает ее одним из дубликатов.

Чтобы исправить это, вы захотите добавить еще одну строку вверху в качестве заголовка, а затем запустить свой код. Вы можете удалить эту ячейку заголовка впоследствии, если хотите.

Если добавление заголовка не является опцией, вы можете использовать удаление дубликатов в качестве отдельного шага. В отличие от расширенного фильтра, вы можете указать удалить дубликаты, если у вас нет заголовка. Просто измените свой код на этот:

 Sub VBARemoveDuplicate()

    Range("A1", Range("A1").End(xlDown)).Select
    Selection.Copy Range("B1")
    Range("B1", Range("B1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo

End Sub
    
 

Редактировать:

Другой альтернативой было бы удалить пропущенный дубликат на серверной части, как я сделал ниже.

 Sub VBARemoveDuplicate()
    Range("A1", Range("A1").End(xlDown)).Select
    Selection.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B1"), Unique:=True
    
    For Each cell In Range("A2", Range("A2").End(xlDown))
        If cell.Value = Range("A1").Value Then
            Range("B1").Delete xlShiftUp
        End If
    Next cell
End Sub
 

Помимо этого, вам нужно будет загрузить все в массив, просмотреть и удалить дубликаты, а затем поместить их обратно на лист. Это может быть медленным, если у вас большой набор данных.

Скопируйте уникальные значения в другой столбец (Словарь)

• Отрегулируйте (поиграйте) значения в разделе константы.

 Option Explicit

Sub VBARemoveDuplicates()
    Const ProcName As String = "VBARemoveDuplicates"
    On Error GoTo ClearError
    
    Const sFirst As String = "A1"
    Const dFirst As String = "B1"
    Const doClearContentsBelow As Boolean = True
    Const doAutoFitColumn As Boolean = True
    
    ' Create a reference to the worksheet.
    Dim ws As Worksheet: Set ws = ActiveSheet
    
    ' Create a reference to the Source Column Range ('srg').
    Dim sfCell As Range: Set sfCell = ws.Range(sFirst)
    Dim srg As Range: Set srg = RefColumn(sfCell)
    If srg Is Nothing Then Exit Sub
    
    ' Write the unique values from the Source Column Range
    ' to the Data Array ('Data').
    Dim Data As Variant: Data = GetUniqueColumnRange(srg)
    If IsEmpty(Data) Then Exit Sub
    
    ' Write the values from the Data Array
    ' to the Destination Column Range ('drg').
    Dim dfCell As Range: Set dfCell = ws.Range(dFirst)
    Dim rCount As Long: rCount = UBound(Data, 1)
    Dim drg As Range: Set drg = dfCell.Resize(rCount)
    drg.Value = Data
    
    ' Clear the contents in the cells of the Clear Range ('crg'),
    ' the range from the first cell below the Destination Column Range
    ' through the last cell in the column.
    If doClearContentsBelow Then
        Dim crg As Range
        Set crg = dfCell.Resize(ws.Rows.Count - dfCell.Row - rCount   1) _
            .Offset(rCount)
        crg.ClearContents
    End If
    
    ' Autofit the Destination Column.
    If doAutoFitColumn Then
        dfCell.EntireColumn.AutoFit
    End If
    
ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" amp; ProcName amp; "': Unexpected Error!" amp; vbLf _
              amp; "    " amp; "Run-time error '" amp; Err.Number amp; "':" amp; vbLf _
              amp; "        " amp; Err.Description
    Resume ProcExit
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the range from the first cell
'               in a column ('ColumnIndex') of a range ('rg') through
'               the last non-empty cell in the column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
    ByVal rg As Range, _
    Optional ByVal ColumnIndex As Long = 1) _
As Range
    Const ProcName As String = "RefColumn"
    On Error GoTo ClearError
    
    ' Validate the parameters.
    If rg Is Nothing Then Exit Function
    ' Also, prevent referencing columns outside of the range.
    If ColumnIndex < 1 Then Exit Function
    If ColumnIndex > rg.Columns.Count Then Exit Function
    
    ' Create a reference to the range.
    With rg.Rows(1).Columns(ColumnIndex)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row   1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Function
        Set RefColumn = .Resize(lCell.Row - .Row   1)
    End With

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" amp; ProcName amp; "': Unexpected Error!" amp; vbLf _
              amp; "    " amp; "Run-time error '" amp; Err.Number amp; "':" amp; vbLf _
              amp; "        " amp; Err.Description
    Resume ProcExit
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the unique values from a column ('ColumnIndex')
'               of a range ('rg') in a 2D one-based one-column array.
' Remarks:      Error and blank values are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetUniqueColumnRange( _
    ByVal rg As Range, _
    Optional ByVal ColumnIndex As Long = 1) _
As Variant
    Const ProcName As String = "GetUniqueColumnRange"
    On Error GoTo ClearError

    ' Validate the parameters.
    If rg Is Nothing Then Exit Function
    ' Also, prevent referencing columns outside of the range.
    If ColumnIndex < 1 Then Exit Function
    If ColumnIndex > rg.Columns.Count Then Exit Function
    
    ' Return the values of the column of the range
    ' in a 2D one-based one-column array.
    Dim Data As Variant
    Dim rCount As Long
    With rg.Columns(ColumnIndex)
        rCount = .Rows.Count
        If rCount = 1 Then
            ReDim Data(1 To 1, 1 To 1): Data(1, 1) = .Value
        Else
            Data = .Value
        End If
    End With
    
    ' Return the unique values of the array
    ' in the keys of a dictionary.
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    Dim Key As Variant
    Dim r As Long
    For r = 1 To rCount
        Key = Data(r, 1)
        If Not IsError(Key) Then
            If Len(Key) > 0 Then
                dict(Key) = Empty
            End If
        End If
    Next r
    
    ' If all values of the column of the range are not unique,
    ' return the keys of the dictionary
    ' in another 2D one-based one-column array.
    r = dict.Count
    Select Case r
    Case 0 ' only error and blank values
        Exit Function
    Case Is < rCount ' fewer unique values than values
        ReDim Data(1 To r, 1 To 1)
        r = 0
        For Each Key In dict.Keys
            r = r   1
            Data(r, 1) = Key
        Next Key
    'Case rCount ' all values are unique - no duplicates
    End Select
    
    ' Return the array.
    GetUniqueColumnRange = Data

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" amp; ProcName amp; "': Unexpected Error!" amp; vbLf _
              amp; "    " amp; "Run-time error '" amp; Err.Number amp; "':" amp; vbLf _
              amp; "        " amp; Err.Description
    Resume ProcExit
End Function