为超过 100,000 行优化循环代码答案

【问题标题】：Optimize code for loop for over 100,000 rows为超过 100,000 行优化循环代码
【发布时间】：2013-12-13 05:21:15
【问题描述】：

我有一个超过 100,000 行和几列的数据集。

我想要实现的是查找另一个范围内的值，如果匹配，则将其放在它旁边的列中。如果有多个匹配的值，请插入另一行并将其放入。

但是，代码需要很长时间才能加载，我的 excel 最终崩溃了……救命！

Sub Splitter_Step1a()

Dim RefSheet As Worksheet
Set RefSheet = ActiveWorkbook.Worksheets("RefList")
Dim ProdSheet As Worksheet
Set ProdSheet = ActiveWorkbook.Worksheets("Products")

Dim Brand, LastBrand, BrandList As Range
Set LastBrand = RefSheet.Range("A1").End(xlDown)
Set BrandList = RefSheet.Range(RefSheet.Range("A1"), LastBrand)

Dim Reference, ReferenceList, LastReference As Range
Set LastReference = ProdSheet.Range("C2").End(xlDown)
Set ReferenceList = ProdSheet.Range(ProdSheet.Range("C2"), LastReference)

Dim BrandInList As Boolean

'Part 1a - assigning brand references to product
For Each Brand In BrandList
For Each Reference In ReferenceList
    If InStr(1, Reference, Brand, 1) And IsEmpty(Reference.Offset(0, 1).Value) Then
        Reference.Offset(0, 1).Value = Brand.Offset(0, 1).Value
        BrandInList = True
    ElseIf Not IsEmpty(Reference.Offset(0, 1).Value) Then
        If InStr(1, Reference, Brand, 1) Then

        Reference.EntireRow.Insert
        Reference.Offset(1, 1).Value = Brand.Offset(0, 1).Value
        BrandInList = True
        End If
    Else
        BrandInList = False
    End If
Next Reference
Next Brand

End Sub

编辑我正在寻找方法来更改代码以完全不使用循环或找到一种方法，以便 excel 不会崩溃并且宏可以在不到 5 分钟内运行..

EDIT2 我的 reflist 是一列，其中的单元格看起来像这样：

Howell Michigan
1234 Detroit Michigan
ABC Detroit Michigan
A Detroit Michigan
Ann Arbor Michigan
334 Ann Arbor Michigan
Amazing Howell & Detroit Kind

我的品牌列表如下所示：

column A       column b
Howell         Howell Michigan
Detroit        Detroit Michigan
Ann Arbor      Ann Arbor Michigan

这个项目的目标是两个部分：
第 1 部分 - 如果参考单元格包含 A 列中的内容，它将返回参考单元格旁边的单元格中 b 列中的内容。
第 2 部分 - 如果出现多次（例如 Howell & Detroit），则在参考单元格旁边的单元格中返回第一列 b 值，然后插入新行并复制所有内容，但将第二列 b 值改为（因此，拆分）

【问题讨论】：

我认为您可以使用COUNTIF()“将其放在旁边的列中”并使用COPY() + PASTE() + REMOVEDUPLICATES() + Sort()“插入另一行并将其放入” --- 你能短示例
如果执行后可以添加三列：RefList的samples、Products的samples和RefList的sample
您可以使用表格格式添加您的示例，如下所示：sensefulsolutions.com/2010/10/format-text-as-table.html
reflist 是单列数据集，还是与它关联的列更多？如果还有其他列，它们中的任何一个都有公式吗？
是的，relist 旁边还有一列包含公式

标签： excel vba loops optimization rows

【解决方案1】：

当您在单元格中写入值时，Excel 必须重绘您的屏幕。因此，对您的代码有帮助的方法是在您写工作表时关闭该功能。

在循环之前尝试此代码。

Application.Screenupdating = False

完成循环后不要忘记再次打开它

Application.Screenupdating = True

另一种选择是使用字符串数组而不是范围数组，这肯定会更慢。例如，您可以在字符串范围内读取您的品牌列表范围，我尚未对其进行测试，但我确定如果您在字符串数组中循环会更快

【讨论】：

他要求优化。这使我的循环速度提高了 100%，所以这是一个答案
品牌列表500+行，参考列表有多少行？。如果他们是另外 500 个，那不应该是一项艰苦的工作。尝试关闭屏幕。如果这不起作用，请尝试制作字符串数组，例如： Dim ArrayS(500) as string 然后用你的 brang 列表填充它，如 ArrayS(1)=Brandlist(1),ArrayS(2)=Brandlist(2).. .ArrayS(i)=品牌列表(i)
品牌列表是 500+ 行，但参考列表是 100,000+ 行。
所以这意味着循环中的代码运行了 500,000 多次。你试过关闭屏幕更新吗？
这就是为什么我要求数据示例

【解决方案2】：

你可以试试：

Sub Splitter_Step1a()

    Dim RefSheet As Worksheet
    Set RefSheet = ActiveWorkbook.Worksheets("RefList")
    Dim ProdSheet As Worksheet
    Set ProdSheet = ActiveWorkbook.Worksheets("Products")

    Dim Brand, LastBrand, BrandList As Range
    Set LastBrand = RefSheet.Range("A1").End(xlDown)
    Set BrandList = RefSheet.Range(RefSheet.Range("A1"), LastBrand)

    Dim Reference, ReferenceList, LastReference As Range
    Set LastReference = ProdSheet.Range("C2").End(xlDown)
    Set ReferenceList = ProdSheet.Range(ProdSheet.Range("C2"), LastReference)

    Dim BrandInList As Boolean, i As Integer

    Application.ScreenUpdating = False
    i = 0

    'Part 1a - assigning brand references to product
    For Each Brand In BrandList
        For Each Reference In ReferenceList
            If InStr(1, Reference, Brand, 1) And IsEmpty(Reference.Offset(0, 1).Value) Then
                Reference.Offset(0, 1).Value = Brand.Offset(0, 1).Value
                BrandInList = True
            ElseIf Not IsEmpty(Reference.Offset(0, 1).Value) Then
                If InStr(1, Reference, Brand, 1) Then

                Reference.EntireRow.Insert
                Reference.Offset(1, 1).Value = Brand.Offset(0, 1).Value
                BrandInList = True
                End If
            Else
                BrandInList = False
            End If
        Next Reference

        i = i + 1
        If i Mod 5 = 0 Then
            Application.StatusBar = "Working: " & i & "/" & UBount(BrandList) 'Update scree to show that the Sub is working
            DoEvents
        End If

    Next Brand
    Application.ScreenUpdating = True
End Sub

PS：也许您可以在最后一行写入而不是 InsertRow，最后您可以再次对 Column 进行排序。 InsertRow 可能需要很长时间。

【讨论】：

【解决方案3】：

首先，让 excel 多次评估表达式会增加负载，因此请尝试存储一些变量。其次，For next 循环在处理方面非常昂贵三、我看到你是用BrandinList来设置真假但是没看你是不是用的

【讨论】：

【解决方案4】：

不确定我是否完全理解，但您能否使用查找作为参考，并且仅对您的品牌使用循环。这可能并不完美，但类似于：

Sub Splitter_Step1a()
Dim i
Dim RefSheet As Worksheet
Set RefSheet = ActiveWorkbook.Worksheets("RefList")
Dim ProdSheet As Worksheet
Set ProdSheet = ActiveWorkbook.Worksheets("Products")

Dim Brand, LastBrand, BrandList As Range
Set LastBrand = RefSheet.Range("A1").End(xlDown)
Set BrandList = RefSheet.Range(RefSheet.Range("A1"), LastBrand)

Dim Reference, ReferenceList, LastReference As Range
Set LastReference = ProdSheet.Range("C2").End(xlDown)
Set ReferenceList = ProdSheet.Range(ProdSheet.Range("C2"), LastReference)

Dim BrandInList As Boolean

'Part 1a - assigning brand references to product
For Each Brand In BrandList
With ProdSheet.Range(ReferenceList)
    Set c = .Find(Brand, LookIn:=xlValues)
    If Not c Is Nothing Then
        firstAddress = c.Address
        i = 0
        Do
            i = i + 1
            If i = 1 Then
                Reference.Offset(0, 1).Value = Brand.Offset(0, 1).Value
            Else
                Reference.EntireRow.Insert
                Reference.Offset(1, 1).Value = Brand.Offset(0, 1).Value
            End If
        Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
End With
Next Brand

End Sub

还可能希望在开始时将 application.calculation 设置为手动，然后在最后将其重新打开。如果您在工作簿中有大量查找，则尤其如此。

【讨论】：