Добрый вечер. У меня есть 2 макроса один с planetiexcel другой с cyberforum
Код
Sub ДУБЛИ_ВЯЧЕЙКЕ_УДЛАИТЬ()
Dim col As New Collection
Dim i As Integer
On Error Resume Next
For Each cell In Selection
Set col = Nothing
sResult = ""
'делим текст в ячейке по пробелам
arWords = Split(WorksheetFunction.Trim(cell.Value), " ")
'проходим в цикле по всем получившимся словам
For i = LBound(arWords) To UBound(arWords)
Err.Clear 'сбрасываем ошибки
col.Add arWords(i), arWords(i) 'пробуем добавить слово в коллекцию
'если ошибки не возникает, то это не повтор - добавляем слово к результату
If Err.Number = 0 Then sResult = sResult & " " & arWords(i)
Next i
cell.Value = Trim(sResult) 'выводим результаты без повторов
Next cell
End Sub
второй макрос
Код
Sub bb()
Dim c As Range, x
With CreateObject("scripting.dictionary")
For Each c In Selection
.RemoveAll
For Each x In Split(c)
.Item(x) = 0
Next
c = Join(.keys)
Next
End With
End Sub
Они удаляют дублируемое слово справа --- яблоко красное [ красное ] яблоко красное [ ] --- Может кто подсказать как сделать что бы удалялось слово слева
Function WithOutDouble$(txt$)
Dim w, i&
w = Split(txt): WithOutDouble = w(UBound(w))
For i = UBound(w) - 1 To 0 Step -1
If InStr(WithOutDouble, w(i)) = 0 Then WithOutDouble = w(i) & " " & WithOutDouble
Next
End Function
Sub RangeDelDouble()
Dim c As Range, w, i&, s$
For Each c In Selection
w = Split(c): s = w(UBound(w))
For i = UBound(w) - 1 To 0 Step -1
If InStr(s, w(i)) = 0 Then s = w(i) & " " & s
Next
c = s
Next
End Sub
Sub мяу()
Dim c As Range, x, s$
For Each c In Selection
With CreateObject("scripting.dictionary")
s = StrReverse(Replace(Replace(c.Value, "[", "[ "), "]", " ]"))
For Each x In Split(s)
.Item(x) = 0
Next
c = StrReverse(Replace(Replace(Join(.keys), " [", "["), "] ", "]"))
End With
Next
End Sub