Top.Mail.Ru
Ответы
Аватар пользователя
4мес
Изменено
Аватар пользователя
Аватар пользователя
Программирование
+1

Помогите написать пользовательскую функцию для Экселя на вба. Нужно написать функцию которая будет объединять все слова

из таблица в одну ячейку. Прототипы этой функции работали исправно,пока не начал писать "словари", после их добавления, функция совсем перестала запускаться и не выдает никаких ошибок. Не понимаю,где ошибся

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960
 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

По дате
По рейтингу
Аватар пользователя
Гуру
4мес

а зачем изобретать велосипед если функция
=СЦЕПИТЬ() давно существует