大循环在VBA中崩溃

Question

截图

我正在使用另一个列表（1）的频率排名更新单词列表（2）。代码设计用于列表1中的每个条目，遍历列表2，并将频率排名添加到其中的每个相同条目。如果我将列表限制为每个列表中的几个条目，它将完全按预期工作，但列表非常大。列表1包含55.000个单词，列表2包含18.000个单词。有没有办法防止代码崩溃，或者以更有效的方式重写代码？我确信它远非最佳，因为我是VBA的完全新手。我将粘贴下面的代码。

非常感谢

Option Explicit
Sub CorrectFrequencyData()

Dim Frequency As Double
Dim CurrentLocation As Range

Application.ScreenUpdating = False

Set CurrentLocation = Range("i5")

Do Until CurrentLocation.Value = ""

    Frequency = CurrentLocation.Offset(0, -6).Value
    Range("n4").Activate

    Do Until ActiveCell.Value = ""

        If ActiveCell.Value = CurrentLocation.Value Then ActiveCell.Offset(0, 1).Value = ActiveCell.Offset(0, 1).Value + Frequency

        ActiveCell.Offset(1, 0).Activate

    Loop

    Set CurrentLocation = CurrentLocation.Offset(1, 0)

Loop

Application.ScreenUpdating = True

End Sub

Answer 1

看起来可能有几种方法可以加快代码速度。首先，您可以在第二个频率列SUMIF中使用=SUMIF(I:I, N4, C:C)作为GavinP建议，如果您将其向下传输到第二个频率列，则说明的是检查第I列中N +行的值在任何地方，您都可以从C列到总计的频率找到该值。

现在可以加速代码的选项：

Option Explicit
Sub CorrectFrequencyData()

Application.ScreenUpdating = False

我不确定您的代码中是否包含公式，但您可以将其设置为手动，而不是每次更改工作表上的值时都重新计算。

Application.Calculation = -4135 'xlCalculationManual

您可以将范围分配给数组并循环更快，而不是遍历工作表。我们还可以消除为第一个列表中的每个条目循环遍历第二个列表的需要。我们通过将第一个单词列表及其频率存储在字典中来完成此操作

Dim ArrWords() as variant
Dim LastRow as long

LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 9).End(-4162).Row  'Version non-specific Endrow, xlUP
ArrWords = Range("C4:I" & LastRow)

Dim dicWordFrequency as Object
Set dicWordFrequency = CreateObject("Dictionary.Scripting")

Dim tempWord as String

Dim i as Long
For i = 1 to Ubound(ArrWords)
    tempWord = arrWords(i,7)
    If not dicWordFrequency.Exists(tempWord) then
       DicWordFrequency.Add tempWord, arrWords(i,1)
    Else
       DicWordFrequency.Item(tempWord)= dicWordFrequency.Item(tempWord) + arrWords(i,1)
    End If
Next

现在我们可以遍历您的工作表并更新第二个列表中单词的频率。

LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 14).End(-4162).Row  'Version non-specific Endrow, xlUP
ArrWords = Range("N4:O" & LastRow)
For i = 1 to Ubound(arrWords)
    tempWord = arrwords(i,1)
    If dicWordFrequency.Exists(tempWord) then
        arrWords(i,2) = dicWordFrequency.Item(tempWord)
    End If
Next        

'Dump your new array with the totals to a range
Dim result as Range
Set Result = Range("N4")
Result.ReSize(UBound(arrWords,1), Ubound(ArrWords,2)).value = arrWords

Application.ScreenUpdating = True
Application.Calculation = -4105  'xlCalculationAutomatic

End Sub