请教大神，这段代码运行速度偏慢，有没有高手改进

透明世界1987

请教大神，这段代码运行速度偏慢，有没有高手改进
Sub 快速查找文件并复制()

Dim souf$, desf$, Rng!, index!, endL!
Dim FileName As String, savePath As String, sourPath As String
Dim objFileSystem As Object

Set objFileSystem = CreateObject("Scripting.FileSystemObject")

sourPath = "\\192.168.10.91\采购共享\未发送订单\"  '要查找的文件所在位置

savePath = "\\192.168.10.91\采购共享\已发送订单\"  '找到后将文件复制到此位置

index = 23 '要查找的文件名所在列

Set mWorkBook = ActiveWorkbook

'FilePath = Replace(mWorkBook.Name, ".pdf", "")

Set mSheet = ActiveWorkbook.ActiveSheet

endL = mSheet.Range("W1000").End(xlUp).Row '获取W列的有效行数

On Error Resume Next '已经存在此文件夹则不创建

VBA.MkDir (savePath & filePath2)  '创建存储的文件夹

    For Rng = 8 To endL '要查找的文件名列表循环

       FileName = mSheet.Cells(Rng, index)

       souf = sourPath & FileName

       If objFileSystem.FileExists(souf) = True Then '判断文件是否存在

        desf = savePath & FileName

        FileCopy souf, desf

        mSheet.Cells(Rng, index).Interior.Color = 65535

       End If
Next
MsgBox "执行完毕！"
End Sub