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

[xamillion]

Что имеем:
- много файлов excel, полученных по запросу из браузера, с беспорядочными названиями...

Что нужно:
- переименовать эти файлы именем, находящееся в 2-х ячейках, т.е. в ячейке A2 первая часть названия файла, а в ячейке A8 - вторая часть... точнее из ячейки A2 взять первые буквы слов, а из A8 взять из набора слов первую дату предварительно переведя ее в буквеное выражение...
файлов может быть очень много!!!

Звучит сложно, по крайней мере, для меня...

[EducatedFool]

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

файлов может быть очень много!!!

Насколько много?
Сотни, тысячи, десятки тысяч?
Все ли эти файлы находятся в одной папке? (или имеется древовидная структура папок - файлы надо искать и во вложенных папках)

а из A8 взять из набора слов первую дату предварительно переведя ее в буквеное выражение

Что делать, если значение в A8 не является датой?
И вообще, с какого листа брать данные?
С первого или с последнего?
Известно заранее имя листа?

[xamillion]

Насколько много?
Сотни, тысячи, десятки тысяч?
Все ли эти файлы находятся в одной папке? (или имеется древовидная структура папок - файлы надо искать и во вложенных папках)

файлов больше 200-300 штук не должно быть... лежат они все в одной папке... во вложениях соответственно искать не надо...

Что делать, если значение в A8 не является датой?

там дата во втором слове (в примере видно), во всех файлах одинаково...

И вообще, с какого листа брать данные?
С первого или с последнего?

лист всего один будет в книге....

Известно заранее имя листа?

Имя заранее неизвестно, но скорее всего будет называться как сам файл до переименования...

[EducatedFool]

Вот весь код:

Sub Main()
    Dim SourceFolder As String, DestinationFolder As String, ce As Range
    InitialPath = ThisWorkbook.Path: Dim coll As New Collection
    Application.ScreenUpdating = False

    SourceFolder = GetFolderPath("Выберите исходную папку для поиска файлов", InitialPath)
    If SourceFolder = "" Then MsgBox "Необходимо указать папку!", vbCritical, "Папка не выбрана": Exit Sub

    DestinationFolder = GetFolderPath("Выберите папку, в которую будет производиться копирование", SourceFolder)
    If DestinationFolder = "" Then MsgBox "Необходимо указать папку!", vbCritical, "Папка не выбрана": Exit Sub

    On Error Resume Next
    If Dir(DestinationFolder, vbDirectory) = "" Then MkDir DestinationFolder    ' если конечная папка не существует, создаём её

    Filename = Dir(SourceFolder & "*.xls")
    Dim wb As Workbook, sh As Worksheet
    While Filename <> ""
        coll.Add Filename: Filename = Dir
    Wend

    For Each file In coll
        Set wb = Workbooks.Open(SourceFolder & file, , True)
        Application.StatusBar = "Обрабатывается файл  " & file    ' вывод информации в строку состояния
        Set sh = wb.Worksheets(3) ' замените на Set sh = wb.Worksheets(1)
        NewFilename = НовоеИмяФайла(sh.Cells(2, 1), sh.Cells(8, 1))
        wb.SaveAs DestinationFolder & NewFilename
        wb.Close False
    Next

    Application.StatusBar = ""
End Sub

Function НовоеИмяФайла(ByVal cell2 As String, ByVal cell8 As String) As String
    '    cell2 = "Наименование товара я-эмульгатор"
    '    cell8 = "Расфасовано 30.08.2009 партия 12.04.2008"
    '    НовоеИмяФайла = "НТЯ август 2009.xls"

    arr = Split(cell2, " ")
    For i = LBound(arr) To UBound(arr)
        НовоеИмяФайла = НовоеИмяФайла & Left(arr(i), 1)
    Next
    НовоеИмяФайла = UCase(НовоеИмяФайла)

    дата = Split(cell8, " ")(1)
    If IsDate(дата) Then НовоеИмяФайла = НовоеИмяФайла & " " & LCase(Format(дата, "MMMM YYYY"))
    НовоеИмяФайла = НовоеИмяФайла & ".xls"
End Function

Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", Optional ByVal InitialPath As String = "c:\") As String
    GetFolderPath = "": PS = Application.PathSeparator
    With Application.FileDialog(msoFileDialogFolderPicker)
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
        If .Show = -1 Then GetFolderPath = .SelectedItems(1): If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
    End With
End Function

[xamillion]

Спасибо... работает отлично... а можно поместиь в ту же папку файлы с новыми названиями вместо старых (старые удалить)?... пробую учиться сам, но пока не все получается...

[EducatedFool]

Попробуйте так: (удаление исходного файла)

Sub Main()
    Dim SourceFolder As String, DestinationFolder As String, ce As Range
    InitialPath = ThisWorkbook.Path: Application.ScreenUpdating = False

    SourceFolder = GetFolderPath("Выберите исходную папку для поиска файлов", InitialPath)
    If SourceFolder = "" Then MsgBox "Необходимо указать папку!", vbCritical, "Папка не выбрана": Exit Sub

    On Error Resume Next
    Filename = Dir(SourceFolder & "*.xls")
    Dim wb As Workbook, sh As Worksheet, coll As New Collection
    While Filename <> "": coll.Add Filename: Filename = Dir: Wend

    For Each file In coll
        Set wb = Workbooks.Open(SourceFolder & file, , True)
        Application.StatusBar = "Обрабатывается файл  " & file    ' вывод информации в строку состояния
        Set sh = wb.Worksheets(3)    ' замените на Set sh = wb.Worksheets(1)
        NewFilename = НовоеИмяФайла(sh.Cells(2, 1), sh.Cells(8, 1))
        wb.SaveAs DestinationFolder & NewFilename
        wb.Close False
        Kill SourceFolder & file
    Next
    Application.StatusBar = "": Application.ScreenUpdating = True
End Sub

Или так: (переименование исходного файла, должно работать быстрее предыдущего способа)

Sub Main()
    Dim SourceFolder As String, DestinationFolder As String, ce As Range
    InitialPath = ThisWorkbook.Path: Application.ScreenUpdating = False

    SourceFolder = GetFolderPath("Выберите исходную папку для поиска файлов", InitialPath)
    If SourceFolder = "" Then MsgBox "Необходимо указать папку!", vbCritical, "Папка не выбрана": Exit Sub

    On Error Resume Next
    Filename = Dir(SourceFolder & "*.xls")
    Dim wb As Workbook, sh As Worksheet, coll As New Collection
    While Filename <> "": coll.Add Filename: Filename = Dir: Wend

    For Each file In coll
        Application.StatusBar = "Обрабатывается файл  " & file    ' вывод информации в строку состояния
        Set wb = Workbooks.Open(SourceFolder & file, , True)
        Set sh = wb.Worksheets(3)    ' замените на Set sh = wb.Worksheets(1)
        NewFilename = НовоеИмяФайла(sh.Cells(2, 1), sh.Cells(8, 1))
        wb.Close False
        Name SourceFolder & file As SourceFolder & NewFilename
    Next
    Application.StatusBar = "": Application.ScreenUpdating = True
End Sub

[xamillion]

и снова спасибо... теперь именно так как нужно...

[xamillion]

Возник еще вопрос:
что добавить в код, чтобы к названию прибавилось все содержимое ячейки A4 (здесь хранится название предприятия, присутствуют ковычки"", они не допустимы в названии файлов...):
If IsDate(дата) Then НовоеИмяФайла = НовоеИмяФайла & " " & LCase(Format(дата, "MMMM YYYY"))

[EducatedFool]

    Предприятие = Replace([a4], """", "'")    ' заменяем двойные кавычки одинарными '
    If IsDate(дата) Then НовоеИмяФайла = Предприятие & " " & НовоеИмяФайла & _
       " " & LCase(Format(дата, "MMMM YYYY"))

[xamillion]

Сообщение от EducatedFool

    Предприятие = Replace([a4], """", "'")    ' заменяем двойные кавычки одинарными '
    If IsDate(дата) Then НовоеИмяФайла = Предприятие & " " & НовоеИмяФайла & _
       " " & LCase(Format(дата, "MMMM YYYY"))

АФИГЕТЬ!!!
А ламером то хреново быть... Хотел сам - пол дня вертел... )))
Спасибо приспасибущее...