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

[SAS888]

Посмотрите пример во вложении. Сделал так, как понял. Что не устраивает?

[MIKID]

Добрый вечер, что то пошло не так.
Предыдущий вариант работает и полностью устраивает, только не понимает пустые и с символами которые не могут быть в имени файла, а так же не понимает что делать с дублями в А1, а так все отлично, отделить бы еще дубли от error, каким нибудь другим именем.
Последний работает не так.
Сейчас программа переименовывает все XLS правильно и перемещает в папку error, а PDF не переименовывает вообще.
Папку error можно вообще исключить, так как при работе оказалось, что пара pdf и xls по имени будет всегда и только одна.
А вот значения в А1 могут попадаться одинаковыми.

Я вложил файлик, посмотрите плиз, по нему Вы поймете, что требуется получить, я видимо плохо объясняю словами.
Огромное спасибо за внимание к моей проблеме!!!!!!!

[MIKID]

Добрый день sas888.
В очередной раз я ввел Вас и всех читающих эту тему в заблуждение.
Последний скрипт работает, это у меня с excel и с головой проблемы.
Помогите решить 3 проблемки.
1. если в А1 символы \ / * : ? " < > | ?, то имя с такими не может быть и программа уходит в ошибку, переименовать такой файл error 1,2,3. и т д
2. если в А1 число, которое уже было использовано для переименования ранее то переименовать pdf duble и это число.
3. Если в А1 в числе из 6 цифр есть пробел, удалить его. К примеру 123 234, чтоб число стало 123234, или 12 34 34 чтоб число стало 123434 и им уже переименовать файл pdf.

спасибо!!

[IgorGO]

Function NewName(ByVal s As String) As String
  Const noChr As String = " \/*:?<>|?"""
  Dim i As Long
  For i = 1 To Len(noChr)
    s = Replace(s, Mid(noChr, i, 1), "")
  Next
  If Dir(s) <> "" Then
    i = 1
    Do While Dir(s & "(" & i & ")") <> "": i = i + 1: Loop
    s = s & "(" & i & ")"
  End If
  NewName = s
End Function

GoodName = NewName([a1])

[SAS888]

Попробуйте следующий вариант.
Если в ячейке "A1" текущего Excel-файла 6 цифр (не считая пробелы), то соответствующий ему pdf-файл будет переименован в это имя. Если такое имя будет повторяться, то pdf-файлы будут переименовываться с добавлением "double_#", где # - номер дубля. Во всех остальных случаях pdf-файлы будут переименовываться в "error_#". Все Excel-файлы будут удалены. Проверяйте. Что не так?

Sub Main()
    Dim p As String, f As String, s As String, ss As String, x As Object, fso
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Укажите рабочую папку": .ButtonName = "Выбрать": .Show
        If .SelectedItems.Count = 0 Then Exit Sub Else p = .SelectedItems(1) & "\"
    End With
    Application.ScreenUpdating = False: f = Dir(p & "*.xls*")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            Set x = GetObject(p & f): s = Replace(x.Sheets(1).[A1], " ", ""): x.Close False
            If Not s Like "######" Then s = "error_1"
            If fso.FileExists(p & fso.GetBaseName(p & f) & ".pdf") Then
                ss = fso.GetBaseName(p & s & ".pdf")
                Do While fso.FileExists(p & s & ".pdf")
                    ss = fso.GetBaseName(p & s & ".pdf"): a = Split(ss, "_")
                    If a(0) Like "double*" Then
                        ss = "double" & StrReverse(Val(StrReverse(a(0)))) + 1 & "_" & a(1)
                    Else
                        If a(0) <> "error" Then ss = "double1_" & a(0) _
                            Else ss = "error_" & StrReverse(Val(StrReverse(a(1)))) + 1
                    End If: s = ss
                Loop
                Name fso.GetFile(p & fso.GetBaseName(p & f) & ".pdf") As p & s & ".pdf"
                Kill p & f
            Else
                'Здесь можно поместить код необходимых действий в случае,
                'еслли для текущего xls-файла в папке нет пары pdf-файла.
            End If: [A1].ClearContents
        End If: f = Dir
    Loop
End Sub

[MIKID]

Добрый вечер SAS888.
Все проверил, просто отлично.
Написал Вам на ICQ, по поводу благодарности.
Ответьте плиз.
СПАСИБО!!!!!!

[SAS888]

Желаю удачи.
Аськой не пользуюсь (удалил из профиля). Пишите на e-mail или в личку.