Vba 映射优化

我有下面的代码可以工作，但需要很长时间才能完成（30K+记录）。有没有关于如何加速的建议

Sub PelsisMapping()
Dim sh1, sh2 As Worksheet
Dim startRow As Integer
Dim foundCell As Range

'Set sheets
'Sheet to Amend
Set sh1 = Sheets("STOCK PELSIS 1")
'Sheet that has mapping data
Set sh2 = Sheets("Mapping")

'set the start row for Sheet1
startRow = 4

'loop until column H of Sheet1 is blank
Do While sh1.Range("H" & startRow) <> ""

  'search id of column A of sheet2 from column H of Sheet2
  Set foundCell = sh2.Range("A:A").Find(sh1.Range("H" & startRow), LookIn:=xlValues)

  'If match id is found, add text in column U of Sheet1. overwriting what is already there
  If Not foundCell Is Nothing Then
    sh1.Range("U" & startRow) = foundCell.Offset(0, 1).Value
  End If

  'increase row
  startRow = startRow + 1
Loop
End Sub

Sub-PelsisMapping（）
尺寸sh1、sh2作为工作表
Dim startRow为整数
作为射程的Dim-foundCell
“床单
"修订附表
设置sh1=板材（“库存PELSIS 1”）
'具有映射数据的工作表
设置sh2=图纸（“映射”）
'设置Sheet1的起始行
startRow=4
'循环，直到活页1的H列为空白
当sh1.Range（“H”和startRow）”时执行此操作
'从sheet2的H列搜索sheet2的A列id
设置foundCell=sh2.Range（“A:A”）.Find（sh1.Range（“H”）和startRow），LookIn:=xlValues）
'如果找到匹配id，请在Sheet1的U列中添加文本。覆盖已经存在的内容
如果不是foundCell，那就什么都不是了
sh1.Range（“U”和startRow）=foundCell.Offset（0，1）.Value
如果结束
"增行"
startRow=startRow+1
环
端接头

您是否在开始时尝试了

application.screenUpdate=false

，在结束时尝试了

=true

？如果您的工作表有公式，请在开始时添加到@CallumDA建议中，

application.Calculation=xlManual

，在结束时添加到

application.Calculation=xlAutomatic

end@CallumDA-工作很愉快@莫阿西-做了一件好事！！您是否在开始时尝试过

application.screenUpdate=false

，在结束时尝试过

=true

？如果您的工作表中有公式，请在开始时添加到@CallumDA建议中，

application.Calculation=xlManual

，在结束时添加到

application.Calculation=xlAutomatic

end@CallumDA-工作很愉快@莫阿西-做了一件好事！！