Страницы: 1
RSS
Перенос в ячейке на другую строку в VBA
 
Есть код функции, которая берет уникальные значения из диапазона и сцепляет их в одну ячейку, так же есть проверка на слово "тест" и пустые строки, они пропускаются.
Код
Function СцепитьУник(rng As Range, Optional sep As String = ", ") As String
Dim x, v, s As String
x = Intersect(rng, ActiveSheet.UsedRange).Value: s = sep
For Each v In x
 v = Trim$(v)
If v <> "тест" And v <> "" Then
    If Len(v) Then If InStr(s, sep & v & sep) = 0 Then s = s & v & sep
End If
Next
СцепитьУник= Mid(s, Len(sep) + 1, Len(s) - Len(sep) * 2)
End Function
Вопрос как задать разделитель чтобы все сцепленные выдавались не одной строкой, а каждое значение переносилось внутри ячейки на новую строку
текст1, текст2, текст3
чтобы получилось
Текст1,
Текст2,
Текст3


И еще такой момент - функция выдает ошибку #ЗНАЧ! Если данные берутся с другого листа. Если данные берутся с этого же листа - ошибки нет. Причем ошибка то появляется то нет.
Изменено: vikttur - 21.07.2021 15:45:46
 
Пример не хотите показать? Откуда берутся данные, предаваемые в функцию?
Dim x, v, s As String - здесь строковая только последяя переменная, x и v - Variant
 
Пример на первом листе все работает как надо, на втором выдает ошибку
 
Для переноса внутри ячейки добавить между сцепляемыми значениями символ переноса Chr$(10). Можно в конце:
Код
СцепитьУник = Replace(Mid(s, Len(sep) + 1, Len(s) - Len(sep) * 2), sep, sep & Chr$(10))

При этом не забыть изменить в ячейке Формат ячейки-Выравнивание-Переносить...

Чтобы функция принимала диапазон с другого листа, замените:
x = Intersect(rng, ActiveSheet.UsedRange).Value
Код
x = rng.Value
Изменено: vikttur - 21.07.2021 15:51:21
 
Наверное так проще
Код
Function СцепитьУник(rng As Range) As String
Dim v As Range
Set dic = CreateObject("System.Collections.ArrayList")
For Each v In rng
    If Not dic.contains(v) Then dic.Add v
Next
СцепитьУник = Join(dic.ToArray, Chr$(10))
End Function
 
vikttur, спасибо! Работает как надо!
msi2102, работает только на первом листе, на втором уникальность отбора не работает.
Спасибо за оперативный ответ!  
Изменено: vikttur - 21.07.2021 18:07:22
 
Извиняюсь, поправил
Код
Function СцепитьУник(rng As Range) As String
Dim v As Range
Set dic = CreateObject("System.Collections.ArrayList")
For Each v In rng
    If Not dic.contains(v.Value) Then dic.Add v.Value
Next
СцепитьУник = Join(dic.ToArray, Chr$(10))
End Function
 
msi2102, нужна еще проверка что ячейка не содержит слово текст или не является пустой.
 
Код
Function MakeList(rng As Range, Optional sep As String = ", ") As String
  Dim v, d
  Set d = CreateObject("Scripting.Dictionary")
  For Each v In Intersect(rng, rng.Parent.UsedRange)
    v = Trim$(v): If v <> "тест" And v <> "" Then d(v) = 1
  Next
  If d.Count > 0 Then MakeList = Join(d.keys, sep)
End Function
только при чем здесь уникальные???
если из множества значений нужно сформировать список значений, составляющий это множество
уникальными в вашем списке являются:
Электромонтер ОПС 4 разряда
Электромонтер ОПС 5 разряда
все остальное - повторяющиеся значения, им так же далеко до уникальных как мне до балета.
Изменено: Ігор Гончаренко - 22.07.2021 09:24:24
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Цитата
Ігор Гончаренко написал:
только при чем здесь уникальные???
Наверное не правильно выразился. Да, нужен список из неповторяющихся значений, чтобы пропускались пустые и содержащие текст "тест" (я не придумал как по другому обойти ошибки #Н/Д или #ЗНАЧ! которые при некоторых обстоятельствах возникают в конце списка значений)
 
код в сообщении выше формирует в ячейке нужный вам список
проверяйте на предмет наличия косяков)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко, Спасибо! Работает как надо. И нет запятой на конце, как в другом варианте
Страницы: 1
Наверх