Блог

Я пытаюсь скопировать столбец из таблицы и вставить его, при этом удаляя дублированные ячейки. Я использую этот код:

 Sub Median()

    Application.Calculation = xlManual
    Application.ScreenUpdating = False

    Worksheets("Distance to Default").Activate

With ActiveSheet

    .Range("C:C").Copy Destination:=.Range("T:T")
    .Range("T:T").RemoveDuplicates , Header:=xlNo

End With

    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True

End Sub
  

msgbox

Все работало бы нормально, если бы не тот факт, что появляется сообщение с просьбой выбрать, для какого столбца я хочу удалить дубликаты (рисунок выше). Поскольку я вставляю только один столбец, вопрос не имеет смысла.

Как я могу изменить свой код, чтобы окно больше не появлялось?

Obs.: Я попытался использовать столбцы: = 1 сразу после удаления дубликатов, и это не сработало

Если вы используете Application.DisplayAlerts = False , сообщение не должно отображаться.

Как упоминалось в моем комментарии выше, я не получаю предупреждения при использовании вашего примера, но этот код обычно подавляет отображение предупреждений.

Добавьте «Столбцы: = 1» в свой код. При этом автоматически выбирается первый столбец диапазона:

 With ActiveSheet

.Range("C:C").Copy Destination:=.Range("T:T")
.Range("T:T").RemoveDuplicates, Columns:=1, Header:=xlNo

End With
  

Обновление: это будет работать на Mac OS

 Sub MacRemoveDuplicates()
    Dim Data, UniqueData, v
    Dim x As Long

    Dim c As Collection
    Set c = New Collection

    With ActiveSheet

        Data = Intersect(.Range("C:C"), .UsedRange)
        ReDim UniqueData(1 To UBound(Data, 1), 1 To 1)

        For Each v In Data
            If v <> vbNullString Then
                On Error Resume Next
                c.Add vbNullString, v

                If Err.Number = 0 Then
                    x = x   1
                    UniqueData(x, 1) = v
                End If
                On Error GoTo 0
            End If
        Next

        .Range("T1").Resize(x) = UniqueData
    End With
End Sub
  

Вот два способа удаления дубликатов с помощью ОС Windows.

 Sub Method1()

    With ActiveSheet
        .Range("C:C").Copy Destination:=.Range("T:T")
        .Range("T:T").RemoveDuplicates Columns:=1, Header:=xlNo
    End With

End Sub


Sub Method2()
    Dim Data, v
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    With ActiveSheet

        Data = Intersect(.Range("C:C"), .UsedRange)

        For Each v In Data
            If v <> vbNullString Then dict(v) = vbNullString
        Next

        .Range("T1").Resize(dict.Count) = Application.Transpose(dict.Keys)
    End With
End Sub