Excel VBA Code/Mcro: Combine Text from multiple rows into one for respective grouping

Here's a VBA code that combines the descriptions for each Team (Column A is Team and Column B Description) and creates a list of unique departments with their combined descriptions in the result sheet: 

Sub CombineDescriptionsByDepartment()

    Dim dataSheet As Worksheet

    Dim resultSheet As Worksheet

    Dim dataRange As Range

    Dim departmentColumn As Range

    Dim descriptionColumn As Range

    Dim departments As Variant

    Dim descriptions As Variant

    Dim department As Variant

    Dim description As Variant

    Dim combinedDescriptions As Object

    Dim rowIndex As Long

    Dim resultTable As Range

    Dim resultRowIndex As Long

    

    ' Set the data sheet and result sheet references

    Set dataSheet = ThisWorkbook.Sheets("Sheet1") ' Replace with your actual data sheet name

    Set resultSheet = ThisWorkbook.Sheets("Sheet2") ' Replace with your actual result sheet name

    

    ' Set the data range references

    Set dataRange = dataSheet.Range("A1:B" & Selection.Rows.Count) ' Adjust the range as per your data

    

    ' Get the department and description columns from the data range

    Set departmentColumn = dataRange.Columns(1)

    Set descriptionColumn = dataRange.Columns(2)

    

    ' Get unique departments and descriptions from the columns

    departments = departmentColumn.Value

    descriptions = descriptionColumn.Value

    

    ' Create a dictionary to store combined descriptions for each department

    Set combinedDescriptions = CreateObject("Scripting.Dictionary")

    

    ' Loop through the data and combine descriptions for each department

    For rowIndex = 2 To UBound(departments)

        department = departments(rowIndex, 1)

        description = descriptions(rowIndex, 1)

        

        If Not combinedDescriptions.Exists(department) Then

            combinedDescriptions(department) = description

        Else

            combinedDescriptions(department) = combinedDescriptions(department) & " " & description

        End If

    Next rowIndex

    

    ' Clear the result sheet

    resultSheet.UsedRange.Clear

    

    ' Write the results to the result sheet

    resultRowIndex = 1

    For Each department In combinedDescriptions.keys

        Set resultTable = resultSheet.Range("A" & resultRowIndex)

        

        ' Write the department name

        resultTable.Value = department

        

        ' Write the combined description

        resultTable.Offset(0, 1).Value = combinedDescriptions(department)

        

        ' Move to the next result row

        resultRowIndex = resultRowIndex + 1

    Next department

    

    MsgBox "Description combination completed."

    

End Sub