vba - 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

看起来可能有几种方法可以加快代码速度。首先，您可以按照GavinP建议的那样使用SUMIF，就像在第二个频率列中使用=SUMIF(I:I, N4, C:C)一样。如果您将其向下流到第二个频率列中，这就是说检查第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