Создать список в столбце без повторов

Пользователь

Сообщений: 157 Регистрация: 03.11.2014

18.06.2025 06:49:40

Здравствуйте, форумчане подскажите пожалуйста. В столбце "D:D" имеется, список Наименование, нужно в этом списке удалить дубликаты, которые повторяются больше одного раза, и подтянуть этот список. Например из этого списка:
Яблоко
Яблоко
Груша
Лимон
Киви
Киви
Лайм
Арбуз
Яблоко
Арбуз
Дыня
Груша
Банан
Виноград
Банан
Виноград
Апельсин
Грейпфрут

Должно получиться это:
Лимон
Лайм
Дыня
Апельсин
Грейпфрут
В примере, есть макрос, который удаляет дубликаты, но только проблема в том, что если "Яблоко" повториться более 1 раза, то он удалит только один повтор, а надо оба.

Код

Sub СоздатьСписокБезПовторов()
    Dim vItem, avArr, i As Long, iColl As New Collection, lastRow As Long
     
    With ActiveSheet
        lastRow = .Cells(.Rows.Count, 4).End(xlUp).Row
        ReDim avArr(1 To lastRow, 1 To 1)
        On Error Resume Next
        For Each vItem In .Range("D2:D" & lastRow).Value
            If Not IsEmpty(vItem) Then
                iColl.Add vItem, CStr(vItem)
                If Err = 0 Then
                    i = i + 1
                    avArr(i, 1) = vItem
                Else
                    Err.Clear
                End If
            End If
        Next
     .Range("D2:D" & lastRow).Value = Empty    ' очистить эти ячейки
    End With
    On Error GoTo 0
    
    If i Then Sheets("Продукты").[D2].Resize(i).Value = avArr
End Sub

Прикрепленные файлы

СоздатьСписокБезПовторов.xlsm (21.66 КБ)

Изменено: Sanja - 18.06.2025 07:00:32 (удалил один файл)

Muxa K Пользователь Сообщений: 359 Регистрация: 05.11.2023	#2 18.06.2025 07:00:58 Delux, здравствуйте. =УНИК(D2:D19;;1) Прикрепленные файлы СоздатьСписокБезПовторов.xlsm (21.65 КБ)

Sanja

Модератор

Сообщений: 19835 Регистрация: 10.01.2013

18.06.2025 07:23:35

Вариант

Код

Sub СоздатьСписокБезПовторов()
Dim arr(), iKey, lRow&
Application.ScreenUpdating = False
With ActiveSheet
  lRow = .Cells(.Rows.Count, 4).End(xlUp).Row
  arr = .Range("D2:D" & lRow).Value
End With
With CreateObject("Scripting.Dictionary")
  For Each iKey In arr
    If Not .Exists(iKey) Then
      .Add iKey, 1
    Else
      .Item(iKey) = .Item(iKey) + 1
    End If
  Next
  For Each iKey In .Keys
    If .Item(iKey) > 1 Then .Remove iKey
  Next
  ActiveSheet.Range("D2:D" & lRow).ClearContents
  ActiveSheet.Range("D2").Resize(.Count) = Application.Transpose(.Keys)
End With
Application.ScreenUpdating = True
End Sub

Согласие есть продукт при полном непротивлении сторон

Delux Пользователь Сообщений: 157 Регистрация: 03.11.2014	#4 18.06.2025 07:42:36 Muxa K, Sanja, Огромное Вам спасибо очень выручил!!!

sotnikov

Пользователь

Сообщений: 558 Регистрация: 29.01.2016

18.06.2025 08:41:52

pq
let from = Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content], gr = Table.Group(from,"Фрукт",{"tmp",Table.RowCount}), to = Table.SelectRows(gr,each [tmp]=1)[Фрукт] in to

pq (v2)
let f=(x)=>((x)=>if List.Count(x)=1 then x else {})(Table.ToList(x)), from = Excel.CurrentWorkbook(){[Name="Таблица1"]}[Content], to = List.Combine(Table.Group(from,"Фрукт",{"tmp",f})[tmp]) in to

Прикрепленные файлы

onlyONE.xlsx (19.43 КБ)

Msi2102 Пользователь Сообщений: 4148 Регистрация: 31.03.2014	#6 18.06.2025 08:58:14 Вкладка Данные --> Работа с данными --> Убрать дубликаты

BodkhiSatva

Пользователь

Сообщений: 689 Регистрация: 01.06.2019

18.06.2025 09:46:32

Цитата
Delux написал: Должно получиться это: Лимон Лайм Дыня Апельсин Грейпфрут

обычным

Цитата
Msi2102 написал: Вкладка Данные --> Работа с данными --> Убрать дубликаты

получается это:
Яблоко
Груша
Лимон
Киви
Лайм
Арбуз
Дыня
Банан
Виноград
Апельсин
Грейпфрут

куда подевали недостающие фрукты? или "все уже украдено до нас"?... ))))

Читают тему