批量提取文件

前半段:

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 = "E:\Desktop\专利数据申请\" '要查找的文件所在位置

 

 

 

 savePath = "E:\Desktop\存储位置\" '找到后将文件复制到此位置

 

   

 

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

 

Set mWorkBook = ActiveWorkbook

 

'filePath = Replace(mWorkBook.Name, ".xlsx", "")

 

Set mSheet = ActiveWorkbook.ActiveSheet

 

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

 

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

 

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

后半段:

For rng = 1 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​

 

 

 

 

 

利用VBA代码根据Excel数据批量复制粘贴文件。

代码如下:

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 = "E:\Desktop\专利数据申请\" '要查找的文件所在位置

 savePath = "E:\Desktop\存储位置\" '找到后将文件复制到此位置

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

Set mWorkBook = ActiveWorkbook

'filePath = Replace(mWorkBook.Name, ".xlsx", "")

Set mSheet = ActiveWorkbook.ActiveSheet

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

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

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

For rng = 1 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​

 

 

• 1
•