Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Удаление повторяющихся значений из одной ячейки
 
#1
04.06.2019 16:45:11
Добрый день! Есть столбец, в котором, например, 5 тысяч ячеек. В каждой ячейке записаны числа через запятую, среди этих чисел есть повторения. Я пытаюсь написать макрос, который бы удалял эти повторения. Например: есть ячейка (5.65; 6.01; 5.3; 10; 12; 10.1; 10; 5; 6.01) после выполнения макроса хочу, чтобы ячейка преобразовывалась в (5.65; 6.01; 5.3; 12; 10.1; 10; 5). Пример во вложении. Надеюсь на вашу помощь.
 
 
 
#2
04.06.2019 17:14:55
kudim, у Вас разделитель там ";" или "; " (точка с запятой+пробел)? Или вообще на точку с запятой не ориентироваться? А на что тогда?
Изменено: Wiss - 04.06.2019 17:15:17
Я не волшебник, я только учусь.
 
 
 
#3
04.06.2019 17:15:20
вариант, на весь столбец допилите сами
Код
For i = 2 To 20
    Set sd = CreateObject("Scripting.Dictionary")
    For Each n In Split(Cells(i, 1), ";")
        sd.Item(Trim(n)) = ""
    Next
    Cells(i, 4) = Join(sd.keys, "; ") 'выводит в столбец d, для А заменить 4 на 1
Next
Изменено: V - 04.06.2019 17:16:51
 
 
 
#4
04.06.2019 17:16:10
в pq
 
 
 
#5
04.06.2019 17:36:05
У V существенно красивее и, вероятно быстрее, но код ниже тоже имеет право на существование (работает с выделенными ячейками).
Код
Option Explicit

Sub delDub()
Dim rngX As Range
Dim c As Range
Dim arrIn As Variant
Dim dictOut As Object
Dim i As Long
Dim sOut As String
Dim key As Variant

    Set rngX = Selection
    
    
    For Each c In rngX
        Set dictOut = CreateObject("Scripting.Dictionary")
        sOut = ""
        
        arrIn = Split(c.Value, "; ")
        
        On Error Resume Next
        For i = LBound(arrIn) To UBound(arrIn)
            dictOut.Add arrIn(i), arrIn(i)
        Next i
        On Error GoTo 0
        
        For Each key In dictOut.keys
            If sOut = "" Then
                sOut = key
            Else
                sOut = sOut & "; " & key
            End If
        Next key
        
        c.Offset(, 2).Value = "'" & sOut
    Next c
End Sub
Я не волшебник, я только учусь.
 
 
 
#6
04.06.2019 17:38:05
для выделенного диапазона
Код
Sub RemoveDuplicates()
    Dim arr As Variant, i&
    With Selection
        arr = .Value
        With CreateObject("vbscript.regexp")
            .Pattern = "(?: |^)(\d+(?:,\d+)*);(?=.*? \1(?:;|$))"
            .Global = 1: .MultiLine = 1
            For i = 1 To UBound(arr)
                If .test(arr(i, 1)) Then arr(i, 1) = Trim(.Replace(arr(i, 1), ""))
            Next
        End With
        .Value = arr
    End With
End Sub
 
 
 
#7
04.06.2019 17:53:17
Спасибо всем огромное!
 
 
 
Страницы: 1
Наверх