Question

我需要在1个文件夹中重命名300多个具有各种扩展名的文件。我的Excel工作表的B列中有一个没有扩展名的文件名列表，而A列中有一个最终名。我的代码有效，但是重命名文件的顺序错误。文件名包含点，例如

А1.14.12.2016

代码如下：

Option Explicit
Sub test2()
    Dim x As String
    Dim fName As String
    Dim oldPath As String
    Dim newPath As String
    Dim i As Long

    oldPath = "\\Plu20\dfs01\USMiKAR\docs\"
    newPath = oldPath & "New\"
    On Error Resume Next
    x = GetAttr(newPath) And 0
    If Err.Number <> 0 Then MkDir newPath
    fName = Dir(oldPath & "*.*")
    With ActiveSheet
        Do While Len(fName) > 0
            i = i + 1
            FileCopy oldPath & fName, newPath & .Cells(i, 1) & Mid$(fName, InStrRev(fName, "."))
            '.Cells(i, 2) = oldPath & fName 'ïðîâåðêà
            'Kill oldPath & fName 'óäàëåíèå ñòàðûõ
            fName = Dir
        Loop
    End With
End Sub

Answer 1

未经测试，但是您可以执行以下操作：

Sub test2()

    Dim x As String
    Dim fName As String
    Dim oldPath As String
    Dim newPath As String
    Dim i As Long
    Dim fso As Object, f As Range

    Set fso = CreateObject("scripting.filesystemobject")

    oldPath = "\\Plu20\dfs01\USMiKAR\docs\"
    newPath = oldPath & "New\"

    If Dir(newPath, vbDirectory) = "" Then MkDir newPath

    fName = Dir(oldPath & "*.*")
    With ActiveSheet
        Do While Len(fName) > 0
            'find the current filename
            Set f = .Columns(2).Find(fso.getbasename(fName), lookat:=xlWhole)
            If Not f Is Nothing Then
                'got a match
                FileCopy oldPath & fName, _
                   newPath & f.Offset(0, -1).Value & "." & fso.getextensionname(fName)
                '.Cells(i, 2) = oldPath & fName 'ïðîâåðêà
                'Kill oldPath & fName 'óäàëåíèå ñòàðûõ
            Else
                'no match...
                Debug.Print "filename:" & fName & " was not matched"
            End If

            fName = Dir
        Loop
    End With
End Sub

根据工作表列表重命名具有各种扩展名的文件夹中的文件

1 个答案: