

Помогите написать пользовательскую функцию для Экселя на вба. Нужно написать функцию которая будет объединять все слова
из таблица в одну ячейку. Прототипы этой функции работали исправно,пока не начал писать "словари", после их добавления, функция совсем перестала запускаться и не выдает никаких ошибок. Не понимаю,где ошибся
Option Explicit
Function CombineColumnsFull(rng As Range) As String
On Error GoTo ErrorHandler
Dim ws As Worksheet
Dim currentRow As Range
Dim mainDict As Object
Dim partABC As String, quartal As String, cellValue As String
Dim output As String, i As Long
' Проверки
If rng Is Nothing Then
CombineColumnsFull = "Ошибка: Диапазон не указан"
Exit Function
End If
If rng.Columns.Count < 5 Then
CombineColumnsFull = "Ошибка: Нужно 5 столбцов (A-E)"
Exit Function
End If
Set ws = rng.Parent
Set mainDict = CreateObject("Scripting.Dictionary")
' Обработка строк
For Each currentRow In rng.Rows
' Формируем ключ A;B;C
partABC = ""
For i = 0 To 2
cellValue = Trim(ws.Cells(currentRow.Row, rng.Column + i).Value
If cellValue = "" Then
CombineColumnsFull = "Ошибка: Пустое значение в строке " & currentRow.Row
Exit Function
End If
partABC = partABC & IIf(partABC = "", "", "; ") & cellValue
Next i
' Получаем квартал (D)
quartal = Trim(ws.Cells(currentRow.Row, rng.Column + 3).Value
If quartal = "" Then
CombineColumnsFull = "Ошибка: Пустой квартал в строке " & currentRow.Row
Exit Function
End If
' Обрабатываем значение E
cellValue = Trim(Replace(ws.Cells(currentRow.Row, rng.Column + 4).Value, " ", " ")) ' Удаляем двойные пробелы
If cellValue = "" Then
CombineColumnsFull = "Ошибка: Пустое E в строке " & currentRow.Row
Exit Function
End If
' Добавляем в словарь
If Not mainDict.Exists(partABC) Then
mainDict.Add partABC, CreateObject("Scripting.Dictionary")
End If
If Not mainDict(partABC).Exists(quartal) Then
mainDict(partABC).Add quartal, New Collection
End If
mainDict(partABC)(quartal).Add cellValue
Next currentRow
' Формируем результат
output = ""
Dim abcKey As Variant, quartalKey As Variant
For Each abcKey In mainDict.Keys
Dim tempOutput As String
tempOutput = abcKey
For Each quartalKey In mainDict(abcKey).Keys
Dim otherValues As String, parteValues As String
otherValues = ""
parteValues = ""
For Each cellValue In mainDict(abcKey)(quartalKey)
If InStr(1, cellValue, "часть выдела ", vbTextCompare) > 0 Then
parteValues = parteValues & ", " & Trim(Replace(cellValue, "часть выдела", ""))
Else
otherValues = otherValues & ", " & cellValue
End If
Next cellValue
' Форматируем
If otherValues <> "" Then otherValues = Mid(otherValues, 3)
If parteValues <> "" Then parteValues = "часть выдела " & Mid(parteValues, 3)
tempOutput = tempOutput & " " & quartalKey & " (" & otherValues
If parteValues <> "" Then
tempOutput = tempOutput & IIf(otherValues = "", "", ", ") & parteValues
End If
tempOutput = tempOutput & ")"
Next quartalKey
output = output & IIf(output = "", "", "; ") & tempOutput
Next abcKey
CombineColumnsFull = output
Exit Function
ErrorHandler:
CombineColumnsFull = "Ошибка: " & Err.Description
End Function
а зачем изобретать велосипед если функция
=СЦЕПИТЬ() давно существует