Архив

Публикации с меткой ‘Работа с текстом’

Функция перемещения слова в строке

 

Я тут недавно понял одну вещь: если необходимо одно слово в предложении поменять местами с другим словом, то через стандартные функции листа Excel это сделать весьма проблематично. Вот и решил создать небольшую функцию пользователя, которая бы умела перемещать слово из одной позиции в другую.

Function Move_SubString(Ячейка As String, Номер_подстроки As Long, Новое_место As Long, Optional Разделитель As String = " ")
    Dim sStr, li As Long
    Dim sNewWord As String, sTmpStr As String
    sStr = Split(Ячейка, Разделитель)
    For li = LBound(sStr) To UBound(sStr)
        If li = Номер_подстроки - 1 Then sTmpStr = sStr(li): sStr(li) = ""
    Next li
 
    For li = LBound(sStr) To UBound(sStr)
        If li = Новое_место - 1 Then
            sNewWord = sNewWord & Разделитель & sTmpStr & Разделитель & sStr(li)
        Else
            sNewWord = sNewWord & Разделитель & sStr(li)
        End If
    Next li
    Move_SubString = Application.Trim(sNewWord)
End Function
Function Move_SubString(Ячейка As String, Номер_подстроки As Long, Новое_место As Long, Optional Разделитель As String = " ")
    Dim sStr, li As Long
    Dim sNewWord As String, sTmpStr As String
    sStr = Split(Ячейка, Разделитель)
    For li = LBound(sStr) To UBound(sStr)
        If li = Номер_подстроки - 1 Then sTmpStr = sStr(li): sStr(li) = ""
    Next li

    For li = LBound(sStr) To UBound(sStr)
        If li = Новое_место - 1 Then
            sNewWord = sNewWord & Разделитель & sTmpStr & Разделитель & sStr(li)
        Else
            sNewWord = sNewWord & Разделитель & sStr(li)
        End If
    Next li
    Move_SubString = Application.Trim(sNewWord)
End Function

Ячейка — текст или ссылка на ячейку с текстом, в котором необходимо переместить слово.

Номер_подстроки — это номер слова в строке, которое перемещаем.

Новое_место — номер позиции слова в строке, куда перемещаем.

Разделитель — необязательный аргумент. По умолчанию — пробел. Этим символом будет разделено перемещаемое слово.

С помощью функции можно либо переместить слово с одной позиции в предложении на другую или поменять слова в предложении местами. В файле-примере вы найдете примеры применения обоих вариантов.

Скачать пример »

  Tips_Macro_MoveSubstring.xls (38,5 KiB, 568 скачиваний)

Также см.:
Работа с текстом
Как перевернуть слово?

Как перевернуть слово?

 

Возможно кому-то и пригодиться, а может кто-то уже и сталкивался с подобной проблемой. Нужно перевернуть слово. Т.е. расположить буквы слова в обратном порядке. Из «привет» сделать «тевирп».  Если честно, то я сам с трудом могу представить себе ситуацию, в которой это реально может пригодиться. Сам использовать лишь в случае, когда надо было перевернуть числовые значения с еще некоторыми манипуляциями. Но что-то я отвлекся. Переворачиваем слово. Сначала я хотел бы описать способы переворачивания слова именно средствами VBA, т.к. именно они кажутся мне наиболее рациональными.

Способ 1: Через встроенную функцию VBA StrReverse(). Быстрый и короткий. Самый удобный. Но работатет только начиная от Excel 2000 и выше.

Sub Reverse_Word()
    Dim sWord As String, sReverseWord As String
    sWord = "Пример"
    sReverseWord = StrReverse(sWord)
End Sub
Sub Reverse_Word()
    Dim sWord As String, sReverseWord As String
    sWord = "Пример"
    sReverseWord = StrReverse(sWord)
End Sub

Способ 2: Более медленный, содержит больше строк кода, но работает во всех версиях:

Sub Reverse_Word()
    Dim sWord As String, sReverseWord As String
    Dim li As Long
    sWord = "Пример"
    For li = Len(sWord) To 1 Step -1
        sReverseWord = sReverseWord & Mid(sWord, li, 1)
    Next li
End Sub
Sub Reverse_Word()
    Dim sWord As String, sReverseWord As String
    Dim li As Long
    sWord = "Пример"
    For li = Len(sWord) To 1 Step -1
        sReverseWord = sReverseWord & Mid(sWord, li, 1)
    Next li
End Sub

Оба кода можно сделать функциями(читать подробнее про функции пользователя и их создание).

' Функция работает с версиями Excel, начиная с 2000
Function Reverse_Word(sWord As String)
    Reverse_Word = StrReverse(sWord)
End Function
 
' Функция работает со всеми версиями Excel
Function Reverse_Word_All(sWord As String)
    Dim sReverseWord As String
    Dim li As Long
    For li = Len(sWord) To 1 Step -1
        sReverseWord = sReverseWord & Mid(sWord, li, 1)
    Next li
    Reverse_Word_All = sReverseWord
End Function
' Функция работает с версиями Excel, начиная с 2000
Function Reverse_Word(sWord As String)
    Reverse_Word = StrReverse(sWord)
End Function

' Функция работает со всеми версиями Excel
Function Reverse_Word_All(sWord As String)
    Dim sReverseWord As String
    Dim li As Long
    For li = Len(sWord) To 1 Step -1
        sReverseWord = sReverseWord & Mid(sWord, li, 1)
    Next li
    Reverse_Word_All = sReverseWord
End Function

Способ стандартными функциями:

Но можно такое сделать и стандартными формулами. Сразу оговорюсь — стандартными формулами сделать это можно, но не совсем просто. Но можно. И для этого потребуется гораздо больше манипуляций, чем через VBA. Хотя для кого-то, возможно, способ формулами будет более прост, чем через VBA. Для начала необходимо будет включить интеративные вычисления в функциях:

  • Excel 2003: Сервис-Параметры-Вычисления-ставим галочку Интерации
  • Excel 2007: Меню-Параметры Excel-Формулы-Включить интеративные вычисления.

Устанавливаем предельное число интераций — 1. Допустим само слово у нас в ячейке А1. Тогда формула будет выглядеть следующим образом:

=ЕСЛИ(ДЛСТР(B1)>=ДЛСТР(A1);B1;ЕСЛИ(ДЛСТР(B1)=1;ПСТР(A1;ДЛСТР(A1);1);B1)&ПСТР(A1;ДЛСТР(A1)-ДЛСТР(B1);1))

Но это не все. При внесении формулы в ячейку она сразу не выдаст необходимый результат. Необходимо пересчитывать формулу до тех пор, пока все слово не перевернется(я просто нажал и удерживал клавишу F9). Лично я сделал формулу, как говорится, «из спортивного интереса». Но кому-то, возможно, будет гораздо проще так, чем через VBA. В приложенном файле помимо рассмотренных примеров есть еще один, котрый лично мне не нравиться тем, что он «растягивается» на несколько ячеек. Это не очень удобно, но избавляет от необходимости включать интерации. Но это, пожалуй, единственный положительный момент в данном способе. Сама формула такова:

=ЕСЛИ(СТОЛБЕЦ(A:A)>ДЛСТР($A1);»";B1&ПСТР($A1;ДЛСТР($A1)+1-СТОЛБЕЦ(A:A);1))

Слово в ячейке A1, B1 должна быть пустой, а уже с B3 начинается формула.

Скачать пример »

  Tips_All_ReverseWord.xls (51,0 KiB, 447 скачиваний)

Так же см.:
Функция перемещения слова в строке

Работа с текстом

 
Данная команда включает в себя набор инструментов для работы со значениями в ячейках:

  • замена символа;
  • удаление символа;
  • смена регистра.

Все три опции могут применяться одновременно.

Работа с текстом

Диапазон значений для замены — указывается ячейка/диапазон ячеек, значения в которых необходимо изменить.

Ячейка для вывода данных — указывается ячейка, в которую надо вывести результат. Если в качестве диапазона значений указан именно диапазон, а не одна ячейка, то преобразованные данные будут выведены, начиная именно с этой ячейки(Ячейка для вывода данных).

Оставить без изменений —  если установить галочку, то указанные на данной вкладке действия не будут произведены. Присутствует на всех вкладках.

Заменяемый символ — один символ(цифра, буква, пробел, точка, запятая — любой символ) который Вы хотите заменить.

Новый символ — символ или группа символов(или слово — зависит от необходимости) на которые будет заменен Заменяемый символ.

Если Заменяемый символ встречается в строке более одного раза, то будут заменены все символы.

На вкладке «Удаление символа» Вы можете задать один вариант из 4(не считая пункта Оставить без изменений):

  • Удалить указанное количество символов от начала строки;
  • Удалить указанное количество символов с конца сроки;
  • Удалить указанное количество символов из середины строки, начиная с указанного символа;
  • Удалить все лишние пробелы из предложений, оставив только одиночные пробелы между словами.

На вкладке «Регистр» Вы можете поменять регистр букв в предложении:

  • все строчные;
  • ВСЕ ПРОПИСНЫЕ;
  • Как в предложениях;
  • Начинать С Прописных.

Также см.:
Извлечение числа из текста
Как оставить в ячейке только цифры или только текст?

Извлечение числа из текста

 

Данная команда позволяет извлечь из текстовых данных либо только число, либо только текст. Ну или оставить в ячейке только текст или только числа. Это уж кому как больше нравится.

Число из текста

Ячейка/диапазон с текстом — указывается ячейка/диапазон ячеек, значения в которых необходимо изменить.

Ячейка для вывода данных — указывается ячейка, в которую надо вывести результат. Если в качестве диапазона значений указан именно диапазон, а не одна ячейка, то преобразованные данные будут выведены, начиная именно с этой ячейки(Ячейка для вывода данных).

Оставить:

  • Оставить только цифры, Оставить только текст — надеюсь не нуждается в разъяснениях — смысл в названии. Единственное, что можно добавить — запятые и точки, являющиеся разделителями дробной и целой частей в числах, не удаляются. В тексте все запятые и точки остаются.
  • Оставлять знаки препинания — установив данный флажок Вы можете определить, какие знаки препинания следует оставить в тексте/числах при извлечении. Знаки препинания, которые следует оставить, необходимо вписать в текстовое поле. По умолчанию оставлены лишь два знака — запятая и точка. Если в поле будут введены числа или буквы — они будут игнорироваться.

Вставлять между цифрами/словами разделитель — если в тексте множественные  разрозненные цифровые значения(например «1 кг яблок за 2 дня» — цифра 1 не имеет отношения к цифре 2 и соединять их не надо), то Вы можете задать для них разделитель. По умолчанию это пробел. После извлечения получиться строка «1 2″. Если разделитель не нужен — просто очистите поле.

Также см.:
Работа с текстом
Как оставить в ячейке только цифры или только текст?

Объединение ячеек без потери значений

 

Как известно, при объединении нескольких ячеек со значениями, Excel оставляет значение только верхней левой ячейки. На мой взгляд это не всегда удобно. Особенно при построении отчетов. Так вот, чтобы объединить ячейки, сохранив все их значения в созданной «одной большой», можно воспользоваться командой Объединение ячеек «Объединение ячеек без потери значений».

Объединение ячеек

Сделать перенос значений на строки —  значение каждой из объединяемых ячеек будет перенесено на новую строку(разделитель, естественно, не указывается)рис.1

Объединить в одну строку — значения объединяемых ячеек объединяются в одну строку друг за другом. При установленной галочке в пункте «Использовать в качестве разделителя«, можно указать разделитель для значений каждой ячейки — рис.2.

Объединение с переносомрис.1

Объединение с разделителемрис.2

Также см.:
Как сцепить несколько значений в одну ячейку по критерию? СцепитьЕсли
Couple_Cells - быстрое сцепление диапазона ячеек
Разбить по строкам/столбцам

Как оставить в ячейке только цифры или только текст?

 

Вот бывает так: есть у Вас в ячейке некий текст. Допустим «Было доставлено кусков мыла 763шт.». Вам нужно из этого только 763 — чтобы можно было провести с этим некие математические действия. Если это только одна ячейка — проблем тут нет, а если таких ячеек пару тысяч? И к тому же все разные?

  • Было доставлено кусков мыла 763шт.
  • Всего пришло 34
  • Тюбики — 54 доставлено
  • и т.д.

Никакой зацепки для извлечения данных. Пару тысяч таких строк удалять вручную весьма утомительное занятие, надо сказать. Да еще и не быстрое. Я хочу предложить Вам пару вариантов решения этой проблемы при помощи VBA. Ниже приведен код пользовательской функции, которая поможет извлечь из строки только числа, либо только текст. Иными словами, результатом функции будет либо только текст, либо только числа.

Function Extract_Number_from_Text(sWord As String, Optional Metod As Integer)
'sWord = ссылка на ячейку или непосредственно текст
'Metod = 0 – числа
'Metod = 1 – текст
    Dim sSymbol As String, sInsertWord As String
    Dim i As Integer
 
    If sWord = "" Then Extract_Number_from_Text = "Нет данных!": Exit Function
    sInsertWord = ""
    sSymbol = ""
    For i = 1 To Len(sWord)
        sSymbol = Mid(sWord, i, 1)
        If Metod = 1 Then
            If Not LCase(sSymbol) Like "*[0-9]*" Then
                If sSymbol = "," Or sSymbol = "." Or sSymbol = " " Then
                    If Mid(sWord, i - 1, 1) Like "*[0-9]*" And Mid(sWord, i + 1, 1) Like "*[0-9]*" Then
                        sSymbol = ""
                    End If
                End If
                sInsertWord = sInsertWord & sSymbol
            End If
        Else
            If LCase(sSymbol) Like "*[0-9.,;:-]*" Then
                If LCase(sSymbol) Like "*[.,]*" Then
                    If Not Mid(sWord, i - 1, 1) Like "*[0-9]*" Or Not Mid(sWord, i + 1, 1) Like "*[0-9]*" Then
                        sSymbol = ""
                    End If
                End If
                sInsertWord = sInsertWord & sSymbol
            End If
        End If
    Next i
    Extract_Number_from_Text = sInsertWord
End Function
Function Extract_Number_from_Text(sWord As String, Optional Metod As Integer)
'sWord = ссылка на ячейку или непосредственно текст
'Metod = 0 – числа
'Metod = 1 – текст
    Dim sSymbol As String, sInsertWord As String
    Dim i As Integer

    If sWord = "" Then Extract_Number_from_Text = "Нет данных!": Exit Function
    sInsertWord = ""
    sSymbol = ""
    For i = 1 To Len(sWord)
        sSymbol = Mid(sWord, i, 1)
        If Metod = 1 Then
            If Not LCase(sSymbol) Like "*[0-9]*" Then
                If sSymbol = "," Or sSymbol = "." Or sSymbol = " " Then
                    If Mid(sWord, i - 1, 1) Like "*[0-9]*" And Mid(sWord, i + 1, 1) Like "*[0-9]*" Then
                        sSymbol = ""
                    End If
                End If
                sInsertWord = sInsertWord & sSymbol
            End If
        Else
            If LCase(sSymbol) Like "*[0-9.,;:-]*" Then
                If LCase(sSymbol) Like "*[.,]*" Then
                    If Not Mid(sWord, i - 1, 1) Like "*[0-9]*" Or Not Mid(sWord, i + 1, 1) Like "*[0-9]*" Then
                        sSymbol = ""
                    End If
                End If
                sInsertWord = sInsertWord & sSymbol
            End If
        End If
    Next i
    Extract_Number_from_Text = sInsertWord
End Function

Данный код необходимо поместить в стандартный модуль книги. А пользоваться очень просто: на листе просто пишите, как обычную формулу:

=Extract_Number_from_Text(A1; 0) или =Extract_Number_from_Text(A1) — если надо оставить только числа

=Extract_Number_from_Text(A1; 1) — если надо оставить только текст

Подробнее про создание пользовательских функции и их применении можно почитать здесь


Помимо функции решил выложить и вариант с использованием UserForm.

рис.1

Выбрать ячейку или диапазон с текстом(Лист1!$A$2:$A$10) - здесь указывается диапазон с исходными значениями, который нужно преобразовать.

Выберите ячейку для вывода данных(Лист1!$A$2) — указывается одна ячейка, с которой начать вывод преобразованных значений. В качестве этой ячейки можно выбрать первую ячейку дипазона с текстом(исходного) если Вам необходимо произвести изменения сразу в этих же ячейках(как на рис.1). Осторожнее с таким указанием, т.к. результат работы кода может быть не совсем таким, какой Вы ожидали. Вернуть прежние данные уже не получится — если только не закрыть файл без сохранения изменений.

Оставить только цифры, Оставить только текст- думаю не надо пояснять. Здесь выбираем, что оставить в качестве результата.

Скачать пример »

  Tips_Macro_Number_From_Text.xls (80,0 KiB, 1 353 скачиваний)

Также см.:
Извлечение числа из текста
Что такое функция пользователя(UDF)?

Как сцепить несколько значений в одну ячейку по критерию? СцепитьЕсли

 

Все чаще вижу на разных форумах вопросы типа: Есть таблица, в одном столбце фамилии, в другом оценки(виды работ и т.д.). Как сцепить в одной ячейке для каждой фамилии только принадлежащие ей оценки? Стандартными функциями это сделать весьма проблематично, т.к. заранее неизвестно сколько будет этих оценок. Вот и решил написать небольшую функцию на VBA, которая решает данную проблему.

Function СцепитьЕсли(ByRef Диапазон As Range, ByVal Критерий As String, ByRef Диапазон_сцепления As Range, Optional Разделитель As String = " ", Optional БезПовторов As Boolean = False) As String
    Dim li As Long, sStr As String, avItem, avDateArr(), avRezArr(), lUBnd As Long
    If Диапазон.Count > 1 Then
        avDateArr = Intersect(Диапазон, Диапазон.Parent.UsedRange).Value
        avRezArr = Intersect(Диапазон_сцепления, Диапазон_сцепления.Parent.UsedRange).Value
        If Диапазон.Rows.Count = 1 Then
            avDateArr = Application.Transpose(avDateArr)
            avRezArr = Application.Transpose(avRezArr)
        End If
    Else
        avDateArr(1, 1) = Диапазон.Value
        avRezArr(1, 1) = Диапазон_сцепления.Value
    End If
    lUBnd = UBound(avDateArr, 1)
    'Опрееделяем вхождение операторов сравнения в Критерий
    Dim objRegExp As Object, objMatches As Object
    Set objRegExp = CreateObject("VBScript.RegExp")
    objRegExp.Global = False: objRegExp.Pattern = "=|<>|=>|>=|<=|=<|>|<"
    Set objMatches = objRegExp.Execute(Критерий)     'Если есть вхождения
    If objMatches.Count > 0 Then
        Dim sStrMatch As String
        sStrMatch = objMatches.Item(0)
        Критерий = Replace(Replace(Критерий, sStrMatch, "", 1, 1), Chr(34), "", 1, 2)
        Select Case sStrMatch
        Case "="
            For li = 1 To lUBnd
                If avDateArr(li, 1) = Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        Case "<>"
            For li = 1 To lUBnd
                If avDateArr(li, 1) <> Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        Case ">=", "=>"
            For li = 1 To lUBnd
                If avDateArr(li, 1) >= Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        Case "<=", "=<"
            For li = 1 To lUBnd
                If avDateArr(li, 1) <= Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        Case ">"
            For li = 1 To lUBnd
                If avDateArr(li, 1) > Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        Case "<"
            For li = 1 To lUBnd
                If avDateArr(li, 1) < Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        End Select
    Else    'Если нет вхождения
        For li = 1 To lUBnd
            If avDateArr(li, 1) Like Критерий Then
                If Trim(avRezArr(li, 1)) <> "" Then _
                   sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
            End If
        Next li
    End If
    If БезПовторов Then
        Dim oDict As Object, sTmpStr
        Set oDict = CreateObject("Scripting.Dictionary")
        sTmpStr = Split(sStr, Разделитель)
        On Error Resume Next
        For li = LBound(sTmpStr) To UBound(sTmpStr)
            oDict.Add sTmpStr(li), sTmpStr(li)
        Next li
        sStr = ""
        sTmpStr = oDict.keys
        For li = LBound(sTmpStr) To UBound(sTmpStr)
            sStr = sStr & IIf(sStr <> "", Разделитель, "") & sTmpStr(li)
        Next li
    End If
    СцепитьЕсли = sStr
End Function
Function СцепитьЕсли(ByRef Диапазон As Range, ByVal Критерий As String, ByRef Диапазон_сцепления As Range, Optional Разделитель As String = " ", Optional БезПовторов As Boolean = False) As String
    Dim li As Long, sStr As String, avItem, avDateArr(), avRezArr(), lUBnd As Long
    If Диапазон.Count > 1 Then
        avDateArr = Intersect(Диапазон, Диапазон.Parent.UsedRange).Value
        avRezArr = Intersect(Диапазон_сцепления, Диапазон_сцепления.Parent.UsedRange).Value
        If Диапазон.Rows.Count = 1 Then
            avDateArr = Application.Transpose(avDateArr)
            avRezArr = Application.Transpose(avRezArr)
        End If
    Else
        avDateArr(1, 1) = Диапазон.Value
        avRezArr(1, 1) = Диапазон_сцепления.Value
    End If
    lUBnd = UBound(avDateArr, 1)
    'Опрееделяем вхождение операторов сравнения в Критерий
    Dim objRegExp As Object, objMatches As Object
    Set objRegExp = CreateObject("VBScript.RegExp")
    objRegExp.Global = False: objRegExp.Pattern = "=|<>|=>|>=|<=|=<|>|<"
    Set objMatches = objRegExp.Execute(Критерий)     'Если есть вхождения
    If objMatches.Count > 0 Then
        Dim sStrMatch As String
        sStrMatch = objMatches.Item(0)
        Критерий = Replace(Replace(Критерий, sStrMatch, "", 1, 1), Chr(34), "", 1, 2)
        Select Case sStrMatch
        Case "="
            For li = 1 To lUBnd
                If avDateArr(li, 1) = Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        Case "<>"
            For li = 1 To lUBnd
                If avDateArr(li, 1) <> Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        Case ">=", "=>"
            For li = 1 To lUBnd
                If avDateArr(li, 1) >= Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        Case "<=", "=<"
            For li = 1 To lUBnd
                If avDateArr(li, 1) <= Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        Case ">"
            For li = 1 To lUBnd
                If avDateArr(li, 1) > Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        Case "<"
            For li = 1 To lUBnd
                If avDateArr(li, 1) < Критерий Then
                    If Trim(avRezArr(li, 1)) <> "" Then _
                       sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
                End If
            Next li
        End Select
    Else    'Если нет вхождения
        For li = 1 To lUBnd
            If avDateArr(li, 1) Like Критерий Then
                If Trim(avRezArr(li, 1)) <> "" Then _
                   sStr = sStr & IIf(sStr <> "", Разделитель, "") & avRezArr(li, 1)
            End If
        Next li
    End If
    If БезПовторов Then
        Dim oDict As Object, sTmpStr
        Set oDict = CreateObject("Scripting.Dictionary")
        sTmpStr = Split(sStr, Разделитель)
        On Error Resume Next
        For li = LBound(sTmpStr) To UBound(sTmpStr)
            oDict.Add sTmpStr(li), sTmpStr(li)
        Next li
        sStr = ""
        sTmpStr = oDict.keys
        For li = LBound(sTmpStr) To UBound(sTmpStr)
            sStr = sStr & IIf(sStr <> "", Разделитель, "") & sTmpStr(li)
        Next li
    End If
    СцепитьЕсли = sStr
End Function

Для применения функции в своем файле достаточно создать стандартный модуль(как это сделать написано здесь) и просто вставить приведенный код. После этого в диспетчере функций появиться новая категория(если до этого её не было)Определенные пользователем. В ней эта функция — СцепитьЕсли.

По принципу работы функция похожа на стандартную СУММЕСЛИ. Указываете диапазон значений, критерий и диапазон значений для сцепления. Символ для разделения слов указывать необязательно.

По умолчанию Разделитель слов — пробел, но можно задать любой другой символ/символы.

Диапазон — диапазон с критериями(указывается один столбец)

Критерий — критерий. Собственно то, с чем сравниваем. Может содержать символы подстановки — * и ?. Просматривается Диапазон. Можно указать символы сравнения с самим критерием сравнения(<>»", <23, >0, <>&A1 и т.п.)

Диапазон_сцепления — из этого диапазона берется значение для сцепления, если значение в аргументе Диапазон совпадает с аргументом Критерий(указывается один столбец)

БезПовторов — если указать 1 или ИСТИНА, то в резульате получится строка, в которой нет одинковых значений. Если указать 0 или ЛОЖЬ, то будут выведены все значения. По умолчанию значение ЛОЖЬ.
Примечание: для работы функции должны быть разрешены макросы.

Скачать пример »

  Tips_Macro_CoupleIf.xls (49,0 KiB, 1 823 скачиваний)

Также см.:
Couple_Cells - быстрое сцепление диапазона ячеек
Что такое функция пользователя(UDF)?