Excel Vba 文件移动到新位置，并重命名文件

 

Excel 表格如下：

运行前：

企业盲号	产品盲号	文件地址	目标文件
1001	100101	D:\标准审核\xxxx\Q5465125412-2021.pdf
1001	100102	D:\标准审核\xxxx\Q5465125412-2020.pdf
1002	100201	D:\标准审核\xxxx\Q5465125412-2018.pdf

运行后：

企业盲号	产品盲号	文件地址	目标文件
1001	100101	D:\标准审核\xxxx\Q5465125412-2021.pdf	D:\目的文件夹\1001\100101.pdf
1001	100102	D:\标准审核\xxxx\Q5465125412-2020.pdf	D:\目的文件夹\1001\100102.pdf
1002	100201	D:\标准审核\xxxx\Q5465125412-2018.pdf	D:\目的文件夹\1002\100201.pdf

'表格第1列为企业盲号，第二列为产品盲号，第三列是源文件地址，第4类用于存放生成的文件地址，第1行为标题行
Sub CopyStdFiles()
    Dim outPutFolder As String
    Dim filePath As String
    Dim companyFolder As String
    Dim productId As String
    Dim companyId As String
    Dim sourceFilePath As String
    Dim i As Integer
    outPutFolder = ThisWorkbook.Path & "\" & "OutPut"
    'MakeNewFolder outPutFolder
    i = 2
    companyId = Application.ActiveSheet.Cells(i, 1)
    Do While companyId <> ""
        productId = Application.ActiveSheet.Cells(i, 2)
        sourceFilePath = Application.ActiveSheet.Cells(i, 3)
        If productId <> "" And sourceFilePath <> "" Then
            companyFolder = outPutFolder & "\" & companyId & "\"
            filePath = companyFolder & productId & "." & GetFileExtention(sourceFilePath)
            If FileExists(filePath) Then
            Kill filePath
            End If
            'Application.Selection.Cells(i, 1).Select
            '生成企业文件夹
            MakeNewFolder companyFolder
            '先拷贝过去
            CopyFileToPath sourceFilePath, companyFolder
            '重命名
            Name companyFolder & GetFileNameWithExtention(sourceFilePath) As filePath
            Application.ActiveSheet.Cells(i, 4) = filePath
        End If
        i = i + 1
       ' If i > 10 Then Exit Do
        companyId = Application.ActiveSheet.Cells(i, 1)
    Loop
End Sub
'复制并粘贴文件
Function CopyFileToPath(sourceFilePath As String, destFolder As String)

Dim MyFile As Object

On Error Resume Next

Set MyFile = CreateObject("Scripting.FileSystemObject")

MyFile.CopyFile sourceFilePath, destFolder

Set MyFile = Nothing

End Function
'创建文件夹
Function MakeNewFolder(foldrName As String)
    If Dir(foldrName, vbDirectory) = "" Then
        MkDir foldrName
    End If
End Function
Function GetFileExtention(filePath As String)
Dim aRet As Variant
aRet = SplitFilename(filePath)
' "路径：" & aRet(1) & vbNewLine & _"文件名：" & aRet(2) & vbNewLine & _"扩展名：" & aRet(3)
GetFileExtention = aRet(3)
End Function
Function GetFileNameWithExtention(filePath As String)
Dim aRet As Variant
aRet = SplitFilename(filePath)
' "路径：" & aRet(1) & vbNewLine & _"文件名：" & aRet(2) & vbNewLine & _"扩展名：" & aRet(3)
GetFileNameWithExtention = aRet(2) & "." & aRet(3)
End Function

'分离文件路径字符串，得到数组：第1个为路径，第二个为 文件名，第三个为后缀
Function SplitFilename(ByVal sFileName As String) As Variant
    
Dim aRet(1 To 3) As String
Dim i As Integer
i = InStrRev(sFileName, "\")
aRet(1) = Left(sFileName, i)
sFileName = Mid(sFileName, i + 1)
i = InStrRev(sFileName, ".")
aRet(2) = Left(sFileName, i - 1)
aRet(3) = Mid(sFileName, i + 1)
SplitFilename = aRet
End Function
'判断文件夹是否存在
Function FileFolderExists(strFullPath As String) As Boolean
    
    If Not Dir(strFullPath, vbDirectory) = vbNullString Then
        FileFolderExists = True
    Else
        FileFolderExists = False
        endi f
    End Function
'判断文件是否存在
Function FileExists(strFullPath As String) As Boolean
    If Not Dir(strFullPath, 16) = vbNullString Then
        FileExists = True
    Else
        FileExists = False
    End If
End Function