Function STexts2(Textrange As Range)
Dim i As Long, x As New Collection, rng As Range: i = 1: On Error Resume Next
For Each rng In Textrange
If Len(rng.Value) > 1 Then x.Add rng.Value, CStr(rng.Value): _
i = i + 1: STexts2 = STexts2 & x(i - 1) & ", "
Next
STexts2 = Left(STexts2, Len(STexts2) - 2)
End Function
Изменено: Vitallic - 13.03.2015 13:26:22(поставил Next "на место")
Hugo написал: "Ааа" - массив из строки, разбитой по запятым с пробелом.
уточню немного. если значение ячейки состоит только из одного слова, то Split(ячейка, ", ") вернет не массив, а одно значение (обычную строку, или число, или что там внутри). Поэтому в коде идет проверка, является ли полученное после Split значение Aaa массивом, или нет. Для массива идет перебор "каждый Spart внутри Ааа", для одиночного значения этот перебор не нужен, пихаем его в словарь сразу. Собственно, поэтому Aaa и Spart и объявлены как Variant - м.б. массив, м.б. строка, м.б. число
Выложил ранее в этой теме макрос который не совсем корректно работает. ТС наверно уже не надо, но может кому пригодится Итак UDF по сбору уникальных значений из определенного диапазона в одной ячейке с вставкой между ними ", " :
Код
Function STexts2(Textrange As Range)
Dim i As Integer, x As Object, rng As Range
Set x = CreateObject("scripting.dictionary")
For Each rng In Textrange
If Len(rng) > 0 And Not x.exists(CStr(rng)) _
Then x.Add CStr(rng), rng: i = i + 1
Next
STexts2 = Join(x.items, ", ")
End Function
Function STexts3(Textrange As Range)
Dim rng As Range
With CreateObject("scripting.dictionary")
For Each rng In Textrange
If Len(rng) > 0 Then .Item(CStr(rng)) = Empty
Next
STexts3 = Join(.keys, ", ")
End With
End Function
Ребята - спасибо всем еще раз за помощь! Все работает хорошо! Супер!! Но тут понадобилось еще кое что.. При сборке в общий файл дублирование убирается хорошо. Но вот проблема новая.. У нас "слово" которое означает одно и то же, но его пишут по разному.. Вот например: SF 120120 или SF120120 или SF-120120 или SD 120120 Можно как нибудь в наш код добавить, дабы он замену осуществлял и приводил любую вариацию этого слова и другого аналогичного к виду SF120120???
Ну допустим можно заменой "убить" всякие пробелы-тире, но вот менять всё что не S после S на F - это вряд ли правильно. Хотя тоже можно. Но мне сейчас некогда... И неплохо бы увидеть файл с текущей версией кода и данными - исходными и что из них нужно получить. Не мне, а всем.
Спасибо! Я понял что глупая затея убирать другие буквы.. А как можно заменить например SF- или Sf или sf- просто на SF?? Вот для примера я книгу сделал. Правда не очень корректно работает удаления запятых, но потому что тут у меня 3й офис, в 10м работает все четко. Вот там модуль и в ней макрос который убирает дублирование и запятые. Как в него можно вклинить процедуру, которая заменит все SF-123123 или sf123123 или sF 123123 просто на SF123123, при этом цифры могут быть абсолютно любые?
Hugo написал: но есть на форуме уже готовые функции, которые можно использовать.
Спасибо! теперь все буквы большие) уже насколько приятнее смотреть! А как примерно звучит название темы. хотя бы примерно? Я в поиске разными вариациями искал по поводу замены символов, толком ничего похожего не получилось найти. (((
Function STexts2(Textrange As Range)
Dim Delimeter As String, i As Long, Aaa, Spart
Delimeter = ","
With CreateObject("scripting.dictionary")
For i = 1 To Textrange.Cells.Count
If Len(Textrange(i)) > 0 Then
Aaa = Split(Textrange(i).Value, Delimeter)
If IsArray(Aaa) Then
For Each Spart In Aaa
If Len(Trim(Spart)) Then .Item(UCase(Replace_symbols(Spart))) = i
Next
Else
If Len(Trim(Spart)) Then .Item(UCase(Replace_symbols(Aaa))) = i
End If
End If
Next i
If .Count > 1 Then STexts2 = Join(.keys, Delimeter & " ") Else STexts2 = Join(.keys, "")
End With
End Function
Private Function Replace_symbols(ByVal sStr As String) As String
Dim i As Byte
Dim St As String
St = " !#$%&'()*+,-./:;<=>?[\]_`{|}~" ' В этой строке лишние символы.
For i = 1 To Len(St)
sStr = Replace(sStr, Mid(St, i, 1), "")
Next
Replace_symbols = sStr
End Function