嗨，我完全懂你现在的困扰——循环调用VLOOKUP确实会让Excel卡顿甚至无响应，尤其是数据量偏大的时候。咱们来一步步拆解问题，从根源上提升宏的运行效率。

问题根源分析 #

你的代码里有两个核心的效率瓶颈：

• 每次循环都调用Application.VLookup，这意味着VBA要频繁和Excel对象模型交互，每一次交互都有不小的性能开销
• 每次VLOOKUP都会完整扫描整个Cont_DB区域，数据越多，重复扫描的成本就越高
• 没有关闭Excel的自动更新、事件触发等后台功能，这些额外操作会进一步拖慢宏的运行速度

优化方案：用字典（Dictionary）替代循环VLOOKUP #

字典是VBA里的高效查找工具，它的查找操作是O(1)时间复杂度，比反复调用VLOOKUP快得多。同时我们还会关闭Excel的后台冗余功能，改用数组批量处理数据，减少和Excel的交互次数。

下面是优化后的完整代码：

Dim Doc_Wkb As Workbook 'Document
Dim DB_Wkb As Workbook 'Database
Dim dbDict As Object
Dim wsDoc As Worksheet, wsDB As Worksheet
Dim docData As Variant, dbData As Variant
Dim i As Long, p As Long
Dim originalCalcMode As XlCalculation
Dim originalScreenUpdating As Boolean
Dim originalEnableEvents As Boolean

' 保存Excel原有设置，运行结束后恢复
originalCalcMode = Application.Calculation
originalScreenUpdating = Application.ScreenUpdating
originalEnableEvents = Application.EnableEvents

' 关闭后台操作，大幅提升运行速度
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

' 打开工作簿并指定目标工作表
Set Doc_Wkb = Workbooks.Open(Doc_Path)
Set wsDoc = Doc_Wkb.Worksheets(Sheet_Name)
Set DB_Wkb = Workbooks.Open(DB_Path)
Set wsDB = DB_Wkb.Worksheets(Sheet_name_2)

' 执行取消合并单元格、去重操作
wsDoc.Cells.UnMerge
wsDoc.Range("A5:S" & wsDoc.Cells(wsDoc.Rows.Count, "S").End(xlUp).Row).RemoveDuplicates Columns:=16, Header:=xlYes

' 初始化字典对象
Set dbDict = CreateObject("Scripting.Dictionary")

' 将数据库数据加载到内存数组（减少和Excel的交互次数）
dbData = wsDB.Range("B:F" & wsDB.Cells(wsDB.Rows.Count, "B").End(xlUp).Row).Value

' 把数据库中的ID和对应名称存入字典（第1列对应B列ID，第5列对应F列名称）
For i = 2 To UBound(dbData) ' 假设数据库第1行是表头
    If Not dbDict.Exists(dbData(i, 1)) Then
        dbDict(dbData(i, 1)) = dbData(i, 5)
    End If
Next i

' 将待处理文档的目标区域数据加载到内存数组
docData = wsDoc.Range("E5:T" & wsDoc.Cells(wsDoc.Rows.Count, "E").End(xlUp).Row).Value

' 批量完成查找匹配
p = 1 ' 数组起始索引为1
Do While p <= UBound(docData)
    If Not IsEmpty(docData(p, 1)) Then ' docData(p,1)对应原E列的ID
        If dbDict.Exists(docData(p, 1)) Then
            docData(p, 16) = dbDict(docData(p, 1)) ' 对应原T列（第20列）
        Else
            docData(p, 16) = "" ' 未匹配到则设为空值
        End If
    End If
    p = p + 1
Loop

' 把处理后的数组一次性写回工作表
wsDoc.Range("E5").Resize(UBound(docData, 1), UBound(docData, 2)).Value = docData

' 恢复Excel原有设置
Application.Calculation = originalCalcMode
Application.ScreenUpdating = originalScreenUpdating
Application.EnableEvents = originalEnableEvents

' 释放对象占用的内存
Set dbDict = Nothing
Set wsDoc = Nothing
Set wsDB = Nothing

' 若需要自动关闭工作簿，可添加以下代码：
' DB_Wkb.Close SaveChanges:=False
' Doc_Wkb.Close SaveChanges:=True

关键优化点解释 #

1. 关闭Excel后台功能：暂停屏幕更新、自动计算和事件触发，避免宏运行时Excel执行不必要的后台操作
2. 数组批量读写：把工作表数据加载到内存数组中处理，完成后一次性写回，大幅减少和Excel对象模型的交互次数
3. 字典高效查找：提前将数据库的ID和对应名称存入字典，后续查找直接通过键值对获取，速度比VLOOKUP提升数倍
4. 明确工作表引用：避免使用未指定工作表的Cells、Rows等代码，防止出现引用错误

这样修改后，你的宏运行速度会有质的提升，再也不会出现Excel无响应的情况了。

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