Найти названия файлов из Excel

[EducatedFool]

2 ZORRO2005

В столбце A будет список файлов из SourceFolder без расширения (могут быть как jpeg ,bmp так и xls,xlsx…).

А нет возможности сделать так, чтобы в столбце А оказались имена файлов с расширениями?

И насчёт расширения файла - оно будет постоянным для каждого случая (например, сегодня обрабатываем папку, содержащую только файлы .jpg, а завтра только файлы .xls), или могут присутствовать файлы с различными расширениями?

В последнем случае возникнут сложности: если в папке SourceFolder будут файлы 01.jpg и 01.bmp, то в том случае, если понадобится переименвать файл 01 в файл 02, то какой из файлов переименовывать?

[ZORRO2005]

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

А нет возможности сделать так, чтобы в столбце А оказались имена файлов с расширениями?

есть такая возможность

И насчёт расширения файла - оно будет постоянным для каждого случая (например, сегодня обрабатываем папку, содержащую только файлы .jpg, а завтра только файлы .xls), или могут присутствовать файлы с различными расширениями?
В последнем случае возникнут сложности: если в папке SourceFolder будут файлы 01.jpg и 01.bmp, то в том случае, если понадобится переименвать файл 01 в файл 02, то какой из файлов переименовывать?

Всё понял,
Вариант1:
У файлов в SourceFolder одинаковое расширение и соответственно нет дубликатов.Столбец A можно тогда сделать без расширений?
Вариант2:
Папка SourceFolder смешанная.
Столбец A c расширениями.

если Вы сделаете 2 вариант,буду очень благодарен.
От расширений очищу с помощью доп. столбца

[EducatedFool]

От расширений очищу с помощью доп. столбца

Не обязательно. Это легко делается программно.

Как формируется список файлов в столбце А?
Надеюсь, не вручную?

И что делать с файлами?
Перемещать или копировать?

У файлов в SourceFolder одинаковое расширение и соответственно нет дубликатов.Столбец A можно тогда сделать без расширений?

Можно, конечно.
Только надо будет (на случай использования одного и того же кода для 2 вариантов) отличать файлы с расширениями от файлов без таковых.
В связи с этим вопрос: возможен ли случай, когда в именах файлов присутствует точка? (например, file1.2008.test.xls)

[ZORRO2005]

Как формируется список файлов в столбце А?
Надеюсь, не вручную?

не вручную

Перемещать или копировать?

Копировать

возможен ли случай, когда в именах файлов присутствует точка?

Будут присутствовать точки

Только надо будет (на случай использования одного и того же кода для 2 вариантов) отличать файлы с расширениями от файлов без таковых

хорошо,пусть будет столбец A c расширениями,столбец B без расширений, а в столбце C новые имена но без расширений.
расширения возьмутся из столбца A.
пример:

  A                B              C  
001.1.jpg    001.1      Арт_001
001.1.xls     001.1      1
002.bmp      002

--------------------------------
001.1.jpg ---> Арт_001.jpg
001.1.xls ---> 1.xls
002.bmp--> не переносится в новую папку, т.к. в столбце С пусто

[EducatedFool]

2 ZORRO2005

Попробуйте такой вариант:

Sub Copy_Files_With_Renaming_Into_Another_Folder()
    On Error Resume Next

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

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


    '    Const SourceFolder = "C:\Documents and Settings\Администратор\Рабочий стол\Исходная папка\"
    '    Const DestinationFolder = "C:\Documents and Settings\Администратор\Рабочий стол\Результат\"

    '[a6:a33].Select    ' выделяем ячейки

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

    Dim ce As Range: Selection.Cells.Interior.ColorIndex = 0

    For Each ce In Selection.Cells
        Filename = Trim$(ce.Value)
        If Len(Filename) > 0 Then
            If Dir(SourceFolder & Filename) <> "" Then
                c2 = Trim$(ce.Offset(, 2).Value): NewFileName = ""
                If Len(c2) > 0 Then    ' если ячейка с новым именем файла пуста, то ничего не делаем
                    NewFileName = c2 & GetFileExt(CStr(Filename))    ' формируем новое имя файла
                    ce.Offset(, 3).Value = NewFileName    ' и записываем его в соседний столбец (для примера)

                    Application.StatusBar = "Копирование файла  " & Filename & "  в папку  " & DestinationFolder
                    FileCopy SourceFolder & Filename, DestinationFolder & NewFileName    ' копирование файла
                    DoEvents
                End If
            End If
            ce.Interior.Color = IIf(NewFileName = "" Or Dir(DestinationFolder & NewFileName) = "", vbYellow, vbGreen)      ' окраска ячеек
        End If
    Next
    Application.StatusBar = ""
End Sub

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

Function GetFileExt(ByVal Filename As String) As String
    ' возвращает расширение файла Filename
    GetFileExt = ""
    For i = Len(Filename) To 2 Step -1
        If Mid$(Filename, i, 1) = "." Then GetFileExt = Mid$(Filename, i): Exit Function
    Next
End Function

Sub PrepareSheetForTest():    ' для теста программы
    For i = 1 To 23: [a7].Offset(i - 1) = "0001 (" & i & ").bmp": Next
    For i = 1 To 23: [c7].Offset(i - 1) = IIf(i Mod 4 = 0, "", Fix(Rnd(i) * 10000)): Next:
End Sub

Код работает при наличии в столбце А имён файлов с расширениями, а в столбце С - новых имён файлов без расширений. Столбец В не нужен (если нужен, его легко сформировать программно)

Выделяете ячейки в столбце А, и запускаете макрос Copy_Files_With_Renaming_Into_Anoth er_Folder

Для примера того, как примерно должны выглядеть исходные данные, запустите макрос PrepareSheetForTest

[ZORRO2005]

EducatedFool,
попробовал, всё отлично работает!
Спасибо огромное!
Можно только подправить, чтобы не надо было выделять ячейки в столбце A?Те, которые надо скопировать указаны в столбце С.

[EducatedFool]

Можно только подправить, чтобы не надо было выделять ячейки в столбце A?Те, которые надо скопировать указаны в столбце С.

Используйте тогда такой код:

Sub Copy_Files_With_Renaming_Into_Another_Folder()
    On Error Resume Next

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

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


    '    Const SourceFolder = "C:\Documents and Settings\Администратор\Рабочий стол\Исходная папка\"
    '    Const DestinationFolder = "C:\Documents and Settings\Администратор\Рабочий стол\Результат\"

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

    Dim ce As Range, ra As Range:
    
    Set ra = Range([c1], [c65000].End(xlUp))
    ra.Cells.Interior.ColorIndex = 0

    For Each ce In ra.Cells
        Filename = Trim$(ce.Offset(, -2).Value): NewFileName = ""
        NewFileName = Trim$(ce.Value)
        If Len(NewFileName) > 0 Then ' если ячейка с новым именем файла пуста, то ничего не делаем
            If Len(Filename) > 0 Then     ' если ячейка со старым именем файла пуста, то ничего не делаем
                If Dir(SourceFolder & Filename) <> "" Then
                    NewFileName = NewFileName & GetFileExt(CStr(Filename))        ' формируем новое имя файла
                    ce.Offset(, 1).Value = NewFileName        ' и записываем его в соседний столбец (для примера)

                    Application.StatusBar = "Копирование файла  " & Filename & "  в папку  " & DestinationFolder
                    FileCopy SourceFolder & Filename, DestinationFolder & NewFileName        ' копирование файла
                    DoEvents
                End If
            End If
            ce.Interior.Color = IIf(NewFileName = "" Or Dir(DestinationFolder & NewFileName) = "", vbYellow, vbGreen)      ' окраска ячеек
        End If
    Next
    Application.StatusBar = ""
End Sub

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

Function GetFileExt(ByVal Filename As String) As String
    ' возвращает расширение файла Filename
    GetFileExt = ""
    For i = Len(Filename) To 2 Step -1
        If Mid$(Filename, i, 1) = "." Then GetFileExt = Mid$(Filename, i): Exit Function
    Next
End Function

Sub PrepareSheetForTest():    ' для теста программы
    For i = 1 To 23: [a7].Offset(i - 1) = "0001 (" & i & ").bmp": Next
    For i = 1 To 23: [c7].Offset(i - 1) = IIf(i Mod 4 = 0, "", Fix(Rnd(i) * 10000)): Next:
End Sub

Он перебирает все заполненные ячейки, начиная с [c1], и заканчивая последней заполненной в столбце С, и, если для заполненной ячейки столбца С есть соотсетствующая заполненная ячейка в столбце А, производит копирование файла.

Выделять никакие ячейки не требуется.

[ZORRO2005]

EducatedFool,
Спасибо огромное еще раз!