Страницы: 1
RSS
Как удалить дубли слов внутри 1 ячейки?
 
Всем привет. Есть подобная тема в архиве за 2012 год, но решения корректного там нет. Может, что то поменялось за 4и года.
Задача следующая, есть строки, в них дубли слов идут в совершенно разном порядке это может происходить. Слова должны проверяться без учета регистра.
 
Код
Sub DelDubl()
Dim i As Long
Dim j As Integer
Dim iLastRow As Long
Dim MyArr
 iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
  Range("B2:B" & iLastRow).ClearContents
  For i = 2 To iLastRow
   With CreateObject("scripting.dictionary"): .comparemode = 1
    MyArr = Split(Cells(i, 1), " ")
      For j = 0 To UBound(MyArr)
        If Not .exists(MyArr(j)) Then
          .Add MyArr(j), 1
          Cells(i, 2) = Cells(i, 2) & MyArr(j) & " "
        End If
      Next
   End With
  Next
End Sub
 
Выделяете нужный диапазон и запускаете макрос, рядом справа он проставит желаемый результат.
Код
Sub d()
Set o = CreateObject("Scripting.Dictionary")
o.CompareMode = 1
s = Selection
ReDim b(1 To UBound(s), 1 To 1)
    For r = 1 To UBound(s)
    o.RemoveAll
    w = ""
        For Each x In Split(s(r, 1), " ")
        y = o(x)
        Next
        
        For Each q In o.keys()
        w = w & q & " "
        Next
    b(r, 1) = w
    Next
Selection.Offset(, 1) = b
End Sub
 
А этот макрос оставит наибольшее релевантное http://www.planetaexcel.ru/forum/index.php?PAGE_NAME=message&FID=1&TID=76488&TITLE_SEO=76488-umenshe...%81%D0%BB%D0%BE%D0%B2%D0%B0&FORUM_ID%5B0%5D=0&DATE_CHANGE=0&order=relevance&s=%D0%9D%D0%B0%D0%B9%D1%82%D0%B8#message640812
 
Бахтиёр, к сожалению выдает ошибку
Скрытый текст

Kuzmich, ваш макрос так же выдает ошибку
Скрытый текст
 
киньте файл, в котором макрос выдаёт ошибку
 
Макрос в стандартный модуль, у меня срабатывает.
 
Бахтиёр, Kuzmich, прикрепил файл. Может ли это быть связанно с тем, что у меня Mac? Ранее пробоем не было с VBA
 
Цитата
kamwork написал: у меня Mac
А СРАЗУ предупредить никак? Для Мак у нас ведь есть отдельный форум.
 
Юрий М, я не знал, что VBA отличается на маке и винде :(
 
Тема создана в разделе МАС.
Не дубль, так как здесь остались решения, для МАС неприменимые
 
Бахтиёр, приветствую. Мне кажется, так буде несколько проще (сделал UDF). Впрочем, могу ошибаться
Код
Function tt(t As String) As String
    Dim col As Object, arr, i  As Long
    Set col = CreateObject("scripting.dictionary")
    col.comparemode = Text
    arr = Split(t)
    For i = 0 To UBound(arr)
        If col.exists(arr(i)) Then arr(i) = "" Else col.Add arr(i), 0
    Next
    tt = Join(arr)
End Function

 
добрый вечер,вариант функции в столбце C
 
Код
Function zzz$(t$)
    Dim tl
 With CreateObject("Scripting.Dictionary"): .comparemode = 1
    For Each t1 In Split(t): .Item(Trim(t1)) = 0: Next
    zzz = Join(.Keys, " ")
 End With
End Function
Изменено: sv2013 - 07.11.2016 21:41:34
 
Цитата
sv2013 написал:
CreateObject("Scripting.Dictionary")
На МАКе не работает!
 
Вот такая функция должна отработать на МАКе:
Код
Function Повторы_В_Ячейке(Cel$) As String
    Dim a, i&
    a = Split(Trim(Cel))
    With New Collection
        For i = 0 To UBound(a)
            On Error Resume Next
            .Add Item:=a(i), Key:=a(i)
            On Error GoTo 0
        Next
        For i = 1 To .Count
            Повторы_В_Ячейке = Повторы_В_Ячейке & " " & .Item(i)
        Next
        Повторы_В_Ячейке = Trim(Повторы_В_Ячейке)
    End With
End Function
Изменено: Михаил С. - 08.11.2016 15:39:30
Страницы: 1
Наверх