循环下来应该在十秒以内吧？不算长。结果也放到数组中，一次性输出。

所以我选择公式

9.4秒，感觉应该可以再优化的，8000*20次(算40的一半)，所以运行时间长，90%时间耗在这里了

一条数据里面存在多个关键字如何处理，全部提取还是提取第一个出现的？

提取第一个出现，这种情况很少

0.08秒，差不多的思路
所以该不是你电脑性能的问题吧？哈哈

但是和你同思路的代码出来结果是很快的啊？
Sub 提取()
Dim crr()
arr = Range([A2], [A65536].End(xlUp))
brr = Range([B2], [B65536].End(xlUp))
ReDim crr(1 To UBound(brr), 1 To 1)
For i = 1 To UBound(brr)
For j = 1 To UBound(arr)
If InStr(brr(i, 1), arr(j, 1)) > 0 Then
crr(i, 1) = arr(j, 1)
Exit For
End If
Next
Next
[C2].Resize(UBound(crr), 1) = crr
End Sub

谢谢呢，我也单独把代码试了下，0.13秒左右，也许问题不是出在这。不管了，反正结果出来了。还是要谢谢你呢！

下边代码仅供参考。
关键词40的时候，下边代码比上边代码慢。
但是当关键词400个的时候，用下边代码会快0.4秒左右。1000关键词的时候，会快0.8秒左右。
Sub 提取()
t = Timer
Dim crr()
arr = Range([A2], [A65536].End(xlUp))
brr = Application.Transpose(Range([B2], [B65536].End(xlUp)))
ReDim crr(1 To UBound(brr), 1 To 1)
For i = 1 To UBound(brr)
　brr(i) = i & "の" & brr(i)
Next
For Each i In arr
　s = VBA.Filter(brr, i)
　If UBound(s) >= 0 Then
　　For Each j In s
　　　crr(Val(j), 1) = i
　　Next
　End If
Next
[C2].Resize(UBound(crr), 1) = crr
MsgBox Timer - t
End Sub

试试range.find方法