Переименование файлов в папке макросом

[MIKID]

Добрый вечер.
У меня похожая задача, но чот не разберусь сам.
Буду очень благодарен за помощь.

Есть папка, в ней файлы PDF и XLS, каждому файлу PDF по названию есть пара XLS.
Нужно:
1. открыть первый файл XLS
2. запомнить значение выбранной ячейки пусть А1
3. Проверить наличие пары файла pdf в этой же директории по имени открытого XLS
4. если такой PDF файл есть, переименовать его значением ячейки
5. закрыть файл XLS и удалить его
6. если пары нет, то переименовать его значением из ячейки А1 и переместить в другую директорию
7. открыть следующий файл и т д. пока все файлы XLS не будут удалены, после переименования найденной пары PDF или перемещены, если пара не найдется.

[IgorGO]

все реализуемо кроме п.6
в части переместить его в ДРУГУЮ директорию, извините, в ДРУГУЮ это куда?

как в анекдоте когда пьяный на улице подходит к прохожему с вопросом:
-- подскажите, пожалуйста, а где тут противоположная сторона?
прохожий показывает рукой. пьяный:
-- да вы издеваетесь!!! а там говорят что здесь!

видите-ли, "ДРУГАЯ директория" есть понятие неопределеннное в Вашем рассказе, как "противоположная сторона" в моем примере

[MIKID]

Добрый день.
6. если пары нет, то переименовать его значением из ячейки А1 и переместить в другую директорию

Я имел в виду в другую папку, что бы этот файл опять не попал под поиск пары. Пусть эта папка будет фиксирована в скрипте, к примеру C:\Error

[EducatedFool]

Посмотрите универсальную надстройку для переименования файлов в папке:
http://excelvba.ru/programmes/RenameFiles


Сделал макрос
Пробуйте:

Sub ПереименованиеФайлов()
    ' используется:
    ' http://excelvba.ru/code/GetValue
    ' http://excelvba.ru/code/FilenamesCollection

    On Error Resume Next
    Dim coll As New Collection
    ' получаем список файлов Excel в папке
    Set coll = FilenamesCollection(ThisWorkbook.path & "\", "*.xls*")
    ErrorFolder$ = "c:\error\"

    For Each Filename In coll
        If Filename <> ThisWorkbook.FullName Then
            ЗначениеЯчейкиA1 = GetValue(ThisWorkbook.path, Dir(Filename, vbNormal), "Лист1", "A1")

            If Len(ЗначениеЯчейкиA1) Then        ' если удалось получить значение ячейки, то

                ' одноимённый файл с XLS
                PDF_filename$ = ThisWorkbook.path & "\" & Split(Dir(Filename, vbNormal), ".xls")(0) & ".pdf"
                ' новое имя файла PDF
                new_PDF_filename$ = ThisWorkbook.path & "\" & ЗначениеЯчейкиA1 & ".pdf"

                If Dir(PDF_filename$, vbNormal) <> "" Then
                    ' если файл ПДФ найден - переименовываем его
                    Name PDF_filename$ As new_PDF_filename$
                    ' и удаляем файл Excel
                    Kill Filename
                Else
                    ' если ПДФ не найден - переименовываем и перемещаем файл XLS
                    MkDir ErrorFolder$
                    Name Filename As ErrorFolder$ & ЗначениеЯчейкиA1 & ".xls"
                End If

            Else
                MsgBox "Не удалось получить значение ячейки A1 с листа Лист1 файла " & vbNewLine & Filename, vbExclamation
            End If
        End If
    Next
    MsgBox "Готово", vbInformation, "Макрос от ExcelVBA.ru"
End Sub

Function GetValue(path, file, sheet, ref)

    If Right(path, 1) <> "\" Then path = path & "\"

    ' проверяем наличие файла по заданному пути
    If Dir(path & file) = "" Then GetValue = "Файл не найден": Exit Function

    ' формируем строку запроса
    arg$ = "'" & path & "[" & file & "]" & sheet & "'!" & _
           Range(ref).Range("A1").Address(, , xlR1C1)

    ' считываем значение из закрытой книги
    GetValue = ExecuteExcel4Macro(arg$)

    ' вместо ошибки возвращаем сообщение об ошибке
    ' к примеру, если лист не найден, или указана несуществующая ячейка
    If IsError(GetValue) Then GetValue = ""
End Function

Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
                             Optional ByVal SearchDeep As Long = 999) As Collection
    ' Получает в качестве параметра путь к папке FolderPath,
    ' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)
    ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
    ' Возвращает коллекцию, содержащую полные пути найденных файлов
    ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)

    Set FilenamesCollection = New Collection        ' создаём пустую коллекцию
    Set FSO = CreateObject("Scripting.FileSystemObject")        ' создаём экземпляр FileSystemObject
    GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep        ' поиск
    Set FSO = Nothing: Application.StatusBar = False        ' очистка строки состояния Excel
End Function

Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
                                 ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
    ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
    ' перебор папок осуществляется в том случае, если SearchDeep > 1
    ' добавляет пути найденных файлов в коллекцию FileNamesColl
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then        ' если удалось получить доступ к папке

        ' раскомментируйте эту строку для вывода пути к просматриваемой
        ' в текущий момент папке в строку состояния Excel
        ' Application.StatusBar = "Поиск в папке: " & FolderPath

        For Each fil In curfold.Files        ' перебираем все файлы в папке FolderPath
            If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.path
        Next
        SearchDeep = SearchDeep - 1        ' уменьшаем глубину поиска в подпапках
        If SearchDeep Then        ' если надо искать глубже
            For Each sfol In curfold.SubFolders        ' перебираем все подпапки в папке FolderPath
                GetAllFileNamesUsingFSO sfol.path, Mask, FSO, FileNamesColl, SearchDeep
            Next
        End If
        Set fil = Nothing: Set curfold = Nothing        ' очищаем переменные
    End If
End Function

[SAS888]

Еще вариант (работоспособность тоже не проверял):

Sub Main()
    Dim p As String, f As String, myDir As String, fso
    myDir = "C:\Error\": p = ThisWorkbook.Path & "\": f = Dir(p & "*.xls")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            [A1].Formula = "='" & p & "[" & f & "]Лист1'!$A$1"
            If [A1].Value <> "" Then
                If fso.FileExists(p & fso.GetBaseName(p & f) & ".pdf") Then
                    Name fso.GetFile(p & fso.GetBaseName(p & f) & ".pdf") As p & [A1] & ".pdf"
                    Kill p & f
                Else
                    Name fso.GetFile(p & f) As myDir & [A1] & ".xls"
                End If
            End If: [A1].ClearContents
        End If: f = Dir
    Loop
End Sub

[MIKID]

ООО ГУРУ!!!!
Огромное спасибо!!!!!!
Все работает!!! Оба варианта.
Только одну проблему не смог победить.
Файлы xls генерит специальная программа, и для версии Microsoft Office Excel 2007 и 2010, она не может.
Чтобы скрипт заработал под Excel 2007, мне пришлось открыть эти файлы и пересохранить под Excel 97-2003. Иначе был ограниченный режим и скрипт не работал.
Как решить без таких заморочек??
И еще можно в скрипте указать какую папку обрабатывать , пусть C:\документы pdf\. Чтобы файл с скриптом там не болтался.

Еще раз спасибо!!!!!

[IgorGO]

замените
p = ThisWorkbook.Path & "\"
на
p = "C:\документыpdf\"

[SAS888]

В предлагаемом ниже варианте сделаны следующие изменения:
1. Добавлен диалог выбора папки с файлами.
2. Добавлена возможность обрабатывать файлы с расширениями ".xls", ".xlsx", ".xlsm" и т. п.
3. Добавлена проверка существования файла в папке, в которую перемещаем файлы. Т. к. автор не указал, что делать в таком случае, то существующий файл будет заменен.

Sub Main()
    Dim p As String, f As String, myDir As String, s As String, fso
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Укажите рабочую папку": .ButtonName = "Выбрать": .Show
        If .SelectedItems.Count = 0 Then Exit Sub Else p = .SelectedItems(1) & "\"
    End With
    myDir = "C:\Error\": f = Dir(p & "*.xls*")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            [A1].Formula = "='" & p & "[" & f & "]Лист1'!$A$1"
            If fso.FileExists(p & fso.GetBaseName(p & f) & ".pdf") Then
                Name fso.GetFile(p & fso.GetBaseName(p & f) & ".pdf") As p & [A1] & ".pdf"
                Kill p & f
            Else
                s = myDir & [A1] & "." & fso.GetExtensionName(p & f)
                If fso.FileExists(s) Then Kill s
                Name fso.GetFile(p & f) As s
            End If
            [A1].ClearContents
        End If: f = Dir
    Loop
End Sub

ВАЖНО: Для того, чтобы обрабатывать файлы с различными Excel-евскими расширениями, необходимо данный макрос запускать в Excel 2007 и выше.

[MIKID]

Спасибо!!
Начал работать, появилось еще одно условие.
В ячейке А1 должно быть только 6 цифр от 0 до 9 и не должно быть никаких других символов. Если присутствует цифр больше или меньше шести или есть символы отличные от цифр то переименовать файл тем что есть но добавить в начале error, файл XLS можно так же удалить.

Выручили, просто низкий поклон!!!

[MIKID]

В последней версии все равно не работает, только после пересохранения файлов xls под Excel 97-2003.
Ошибка:
После запуска макроса в ячейке А1 файла со скриптом появляется ссылка ='C:\Users\MIKI\Documents\Задача автоматиз нарядов\[1 (1).xls]Лист1'!$A$1 файлы не переименовываются.
Запускаю скрипт из Excel 2007