Переименование файлов в папке с различными расширениями в соответствии со списком листов

Question

Мне нужно переименовать 300+ файлов различных расширений в 1 папку. У меня есть список имен файлов без расширения в столбце B и окончательные имена в столбце A моего листа Excel. Мой код работает, но файлы переименовываются в неправильном порядке. Имена файлов содержат точки, например

А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