优化超过100,000行的循环代码

我有一个超过10万行和几列的数据集。

我试图实现的是在另一个范围内查找值，如果它匹配，把它放在旁边的列。 如果有多个匹配的值，则插入另一行并放入。

然而，代码需要永久加载和我的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 

编辑我正在寻找方法来改变代码，以完全不使用循环或find一种方式，使Excel不会崩溃，macros可以在不到5分钟内运行..

编辑2我的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 

这个项目的目标是2个部分：
第1部分 – 如果引用单元格包含A列中的内容，它将返回参考单元格旁边单元格中列b中的内容。
第2部分 – 如果有多个事件发生（例如Howell和Detroit），则返回参考单元格旁边单元格中的第一列b值，然后插入一个新行并复制所有内容，而不是放置第二列b值（因此，SPLIT ）

Answer 1

当您在单元格中写入值时，Excel必须重新绘制屏幕。 所以对你的代码有帮助的东西就是在你书写的时候closures那个函数。

在循环之前试试这个代码。

 Application.Screenupdating = False 

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

 Application.Screenupdating = True 

另一个select是使用数组的string数组范围将肯定会更慢。 你可以例如阅读你的brandlist范围在一个string范围，我还没有testing，但我确定如果你循环在一个string数组将更快

Answer 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，你可以写在最后一行，最后你可以重新sorting列。 InsertRow可能需要很多时间。

Answer 3

首先，excel多次评估expression式加载，所以尝试存储在一些variables。 其次，对于下一个循环在处理方面是非常昂贵的第三，我看到你正在使用BrandinList设置true和false，但是我不知道你是否在使用它

Answer 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转换为开始手动，然后在最后打开它。 如果您在工作簿中查找了很多，则尤其如此。