VBA宏运行缓慢易卡顿，求INDEX MATCH公式优化方案

原代码的核心问题是公式嵌套了数组型COUNTIF运算，如果MyFile表数据量较大，每个单元格都要遍历Database的A列全量数据，重复计算导致耗时剧增。以下是两种高效优化方案：

方案一：纯VBA内存运算（推荐，速度提升最明显） #

通过将数据读取到内存数组，用循环快速匹配，最后批量写入结果，全程减少Excel单元格交互，大幅降低耗时：

Sub MarkLanguage()
    Dim wsDB As Worksheet, wsMF As Worksheet
    Dim langArr As Variant, fileArr As Variant, resultArr As Variant
    Dim i As Long, j As Long
    Dim foundLang As String
    
    ' 基础优化设置：关闭屏幕更新、自动计算、事件
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    ' 定义工作表
    Set wsDB = ThisWorkbook.Worksheets("Database")
    Set wsMF = ThisWorkbook.Worksheets("MyFile")
    
    ' 读取Database的语言列表到数组（假设A列从A2开始有数据）
    langArr = wsDB.Range("A2:A" & wsDB.Cells(wsDB.Rows.Count, "A").End(xlUp).Row).Value
    
    ' 读取MyFile的D列数据（假设从D2开始有数据）
    With wsMF
        fileArr = .Range("D2:D" & .Cells(.Rows.Count, "D").End(xlUp).Row).Value
        ' 初始化结果数组
        ReDim resultArr(1 To UBound(fileArr), 1 To 1)
    End With
    
    ' 循环匹配语言
    For i = LBound(fileArr) To UBound(fileArr)
        foundLang = ""
        For j = LBound(langArr) To UBound(langArr)
            ' 判断D列内容是否包含当前语言（不区分大小写）
            If InStr(1, fileArr(i, 1), langArr(j, 1), vbTextCompare) > 0 Then
                foundLang = langArr(j, 1)
                Exit For ' 找到第一个匹配就退出循环
            End If
        Next j
        resultArr(i, 1) = foundLang
    Next i
    
    ' 批量写入结果到第14列（即N列，若原需求是R列可改为"R2"）
    wsMF.Range("N2").Resize(UBound(resultArr), 1).Value = resultArr
    
    ' 恢复基础设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

代码说明： #

• 所有数据先读到内存数组，避免频繁读写Excel单元格（这是VBA卡顿的核心原因）
• 内存内循环匹配比单元格公式运算快10倍以上
• 关闭屏幕更新、自动计算等，减少Excel后台冗余操作
• 最后批量写入结果，一次完成单元格更新

方案二：优化公式+批量填充 #

如果坚持用公式，改用更高效的XLOOKUP（Excel 365/2021支持）替代嵌套的INDEX/MATCH/COUNTIF，同时批量填充公式，减少重复计算：

Sub OptimizeFormula()
    Dim wsMF As Worksheet, wsDB As Worksheet
    Dim lastRowMF As Long, lastRowDB As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set wsMF = ThisWorkbook.Worksheets("MyFile")
    Set wsDB = ThisWorkbook.Worksheets("Database")
    lastRowMF = wsMF.Cells(wsMF.Rows.Count, "D").End(xlUp).Row
    lastRowDB = wsDB.Cells(wsDB.Rows.Count, "A").End(xlUp).Row
    
    ' 批量填充XLOOKUP公式到目标列（此处为R列，对应原代码位置）
    wsMF.Range("R2:R" & lastRowMF).Formula2 = _
        "=XLOOKUP(TRUE,ISNUMBER(SEARCH(Database!$A$2:$A$" & lastRowDB & ",D2)),Database!$A$2:$A$" & lastRowDB & ","""")"
    
    ' 强制计算后转为值（避免后续打开文件时重复计算）
    wsMF.Range("R2:R" & lastRowMF).Value = wsMF.Range("R2:R" & lastRowMF).Value
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

公式说明： #

• SEARCH不区分大小写查找D2是否包含Database的语言
• ISNUMBER返回布尔数组，XLOOKUP找到第一个匹配的语言
• 最后把公式转为值，避免文件打开时重新计算

额外注意事项 #

• 原需求提到“第14列”，但原代码操作的是R列（第18列），注意根据实际需求调整目标列范围
• 如果语言列表或配置文件数据量超过10万行，方案一的内存运算优势会更显著
• 若需区分大小写匹配，将InStr的vbTextCompare参数改为vbBinaryCompare即可

内容的提问来源于stack exchange，提问作者HelpMe