Looping through more than 5.000 rows? Improvements needed - vba

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?