Vba 在5000多行中循环？需要改进

我可以改进下面的代码吗？或者有没有其他方法可以在更短的时间内完成我的目标

我的目标是将各个国家和类别的独特品牌名称连接起来

在当前结构中，一行代表一个品牌、一个类别和一个国家。在我的输出中，我希望在每个品牌的行上，有一个包含所有国家/地区的连接单元格和一个包含所有类别的连接单元格

到目前为止，我的解决方案是：

我有一个Excel工作簿，它有三张帮助页、输入和输出

帮助表包含没有重复项的品牌名称列表。Inputhas原始数据一行一条。每个品牌名称的输出应填写一行

Inputapprox。25000行。 帮助表。5000行

编辑：现在我使用变量来存储我的范围，以避免VBA/工作表开销。现在我得到一个内存不足错误

我在VBA中写道：

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

然而，这需要很长的时间来计算

---

有什么改进吗？

使用变体可能会复制Okay，这会加快代码的速度，但是如何使用偏移量属性呢？换句话说，我如何从同一行中的不同单元格中检索值？尝试一些方法，然后就特定问题提出一个新问题。这个太宽了。更改了它，但出现内存不足错误。我无法分割数据集。不过，我会尝试更多。变型方式绝对更快。Dim ipRange作为变型Dim hsRange作为变型-这些不应该是范围而不是变型吗？