Looping through more than 5.000 rows? Improvements needed

Question

Can I improve the following code or is there another way to accomplish my goals in less time?

My goal is to concatenate countries and categories of unique brand names.

In the current structure one row represents one brand, one category and one country. In my output I want on row per brand, that has a concatenated cell with all countries and a concatenated cell with all categories.

My solution so far:

I have an Excel-Workbook that has three sheets "HelpSheet","Input" and "Output".

"HelpSheet"contains the list of brand names without duplicates. "Input"has the original data (one row, one entry). "Output"should be filled with one row per brand name.

"Input"approx. 25.000 rows. "HelpSheet"approx. 5.000 rows.

EDITED: Now I am using variants to store my Range to avoid VBA/Worksheet overhead. Now I get an "Out of memory"-Error.

In VBA I wrote this:

Sub CellsTogether()

Dim ipRange As Variant
Dim hsRange As Variant
Dim countryCount As Long
Dim categoryCount As Long
Dim brandArray() As String
Dim categoryStr As String
Dim countryStr As String
Dim countryArr() As String
Dim categoryArr() As String
Dim identifier As String
Dim i As Long
Dim j As Long
Dim iRow As Long
Dim iCol As Long
Dim k As Long
Dim l As Long
Dim lastRow As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

ipRange = Worksheets("Input").Range("B3:N29316")
hsRange = Worksheets("HelpSheet").Range("A1:A4781")
countryCount = 1
categoryCount = 1

For j = LBound(hsRange, 1) To UBound(hsRange, 1)
    For iRow = LBound(ipRange, 1) To UBound(ipRange, 1)
        iCol = 1
        If ipRange(iRow, iCol) = hsRange(j, 1) Then

            ReDim Preserve countryArr(1 To countryCount)
            ReDim Preserve categoryArr(1 To categoryCount)

            For k = LBound(countryArr) To UBound(countryArr)
                If countryArr(k) = ipRange(iRow, iCol + 2) Then
                    Exit For
                Else
                    countryArr(UBound(countryArr)) = ipRange(iRow, iCol + 2)
                    countryCount = countryCount + 1
                End If
            Next k

            For l = LBound(categoryArr) To UBound(categoryArr)
                If categoryArr(l) = ipRange(iRow, iCol + 12) Then
                    Exit For
                Else
                    categoryArr(UBound(categoryArr)) = ipRange(iRow, iCol + 12)
                    categoryCount = categoryCount + 1
                End If
            Next l

            identifier = ipRange(iRow, iCol + 3)

        End If
    Next iRow

    For k = LBound(countryArr) To UBound(countryArr)
        countryStr = countryStr & countryArr(k) & Chr(10)
    Next k
    For k = LBound(categoryArr) To UBound(categoryArr)
        categoryStr = categoryStr & categoryArr(k) & Chr(10)
    Next k

    Worksheets("Output").Cells(j + 2, 3).Value = hsRange(j, 1)
    Worksheets("Output").Cells(j + 2, 6).Value = countryStr
    Worksheets("Output").Cells(j + 2, 5).Value = categoryStr
    Worksheets("Output").Cells(j + 2, 2).Value = identifier

Next j

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

End Sub

However this takes a very long time to calculate.

Any improvements?