Как переименовать все файлы в папке, на имена из столбца таблицы excel?

[Serge_Bliznykov]

Сообщение от Aleksandr H.

А если файлов в папке > ячеек в А ?

и в ответ — тишина...


ладно. посмотрите пример, который я своим корявыми руками собрал из разных кусков кода (за основу взят код (с) EducatedFool):
rename_jpeg.rar

ВНИМАНИЕ!
ПЕРЕИМЕНОВАНИЕ НЕОБРАТИМО!
Если число заполненных ячеек в столбце А и количество JPG файлов в указанной папке не совпадает, то переименование не выполяется, в противном случае - переименование происходит быстро и бесповоротно.
Будьте осторожны и имейте копию данных.




А код в файле такой:

Private Sub CommandButton1_Click()
   Dim SourceFolder As String, InitialPath As String
   Dim file_names() As String, NewFilename As String
   Dim cell As Range, i As Long, countFiles As Long
   
   InitialPath = ThisWorkbook.Path: Application.ScreenUpdating = False
   
   SourceFolder = GetFolderPath("Выберите исходную папку для поиска файлов", InitialPath)
   If SourceFolder = "" Then MsgBox "Необходимо указать папку!", vbCritical, "Папка не выбрана": Exit Sub
   
   On Error Resume Next
   file_names = getSortedFiles(SourceFolder & "*.jpg")
   
   countFiles = UBound(file_names, 1) - LBound(file_names, 1) + 1
   MsgBox ("Найдено : " & CStr(countFiles) & "  jpeg файла(ов)")
   
   ' для отладки вывести имена файлов в столбец B
   For i = 1 To countFiles
      Cells(i, 2) = file_names(i)
   Next i
   
   i = 0
   For Each cell In Range([A1], Range("A" & Rows.Count).End(xlUp)).Cells ' перебираем ячейки в столбце А
     If Trim(cell) <> "" Then
       i = i + 1
     End If
   Next cell
   
   MsgBox "Найдено заполненных ячеек в столбце А ровно " & CStr(i) & " штук."
   
   If i <> countFiles Then MsgBox "Не совпадает число файлов с количеством заполненных ячеек!", vbCritical, "Ошибка исходных данных": Exit Sub
   i = 0
   For Each cell In Range([A1], Range("A" & Rows.Count).End(xlUp)).Cells ' перебираем ячейки в столбце А
     If Trim(cell) <> "" Then
        i = i + 1
        NewFilename = Trim(cell) & ".jpg"
        Application.StatusBar = "Обрабатывается файл  " & file_names(i) & " переименовываем в " & NewFilename  ' вывод информации в строку состояния
        'MsgBox "Обрабатывается файл  " & file_names(i) & " переименовываем в " & NewFilename
        Name SourceFolder & file_names(i) As SourceFolder & NewFilename    ' переименовать файл
     End If
   Next cell
   
   Application.StatusBar = "": Application.ScreenUpdating = True
   
End Sub

ну и дополнительные функцию, вызываемые в коде:

Option Explicit

Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", Optional ByVal InitialPath As String = "c:\") As String
    Dim PS 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


Public Function getSortedFiles(ByVal dir_path As String) As String()
    Dim Filename As String, file As Variant
    Dim i As Long, j As Long, file_names() As String, coll As New Collection, lngCnt As Long, strBuffer1 As String


    Filename = Dir(dir_path)
    While Filename <> "": coll.Add Filename: Filename = Dir: Wend

    ' Make the list of names.
    'ReDim file_names(1 To fso_folder.Files.Count)
    lngCnt = coll.Count
    ReDim file_names(1 To coll.Count)
    i = 1
    For Each file In coll
        file_names(i) = file
        i = i + 1
    Next

    ' Sort the list of files.
    ' Quicksort file_names, 1, coll.Count
    'sort array by numeric value
    For i = 1 To lngCnt
        For j = (i + 1) To lngCnt
            If UCase(file_names(i)) > UCase(file_names(j)) Then
                strBuffer1 = file_names(j)
                file_names(j) = file_names(i)
                file_names(i) = strBuffer1
            End If
        Next
    Next


    ' Return the sorted list.
    getSortedFiles = file_names
End Function

[vefer]

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

Как прописать, что бы имя файла бралось каждый раз не с одной и той же ячейки, а опускалось по столбцу вниз. А1, А2, А3... итд ? новый файл следующая ячейка?

как нибудь так:

NewFilename = НовоеИмяФайла(sh.Cells(rc, 1))
rc=rc+1

Только где нибудь перед циклом For Each напишите rc=1

[djrec]

Сообщение от Aleksandr H.

А если файлов в папке > ячеек в А ?

Перед запуском я буду проверять, что бы их было столько же. Иначе попереименовует некорректно.

[djrec]

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

и в ответ — тишина...


ладно. посмотрите пример, который я своим корявыми руками собрал из разных кусков кода (за основу взят код (с) EducatedFool):
Вложение 88584




ВНИМАНИЕ!
ПЕРЕИМЕНОВАНИЕ НЕОБРАТИМО!
Если число заполненных ячеек в столбце А и количество JPG файлов в указанной папке не совпадает, то переименование не выполяется, в противном случае - переименование происходит быстро и бесповоротно.
Будьте осторожны и имейте копию данных.




А код в файле такой:

Private Sub CommandButton1_Click()
   Dim SourceFolder As String, InitialPath As String
   Dim file_names() As String, NewFilename As String
   Dim cell As Range, i As Long, countFiles As Long
   
   InitialPath = ThisWorkbook.Path: Application.ScreenUpdating = False
   
   SourceFolder = GetFolderPath("Выберите исходную папку для поиска файлов", InitialPath)
   If SourceFolder = "" Then MsgBox "Необходимо указать папку!", vbCritical, "Папка не выбрана": Exit Sub
   
   On Error Resume Next
   file_names = getSortedFiles(SourceFolder & "*.jpg")
   
   countFiles = UBound(file_names, 1) - LBound(file_names, 1) + 1
   MsgBox ("Найдено : " & CStr(countFiles) & "  jpeg файла(ов)")
   
   ' для отладки вывести имена файлов в столбец B
   For i = 1 To countFiles
      Cells(i, 2) = file_names(i)
   Next i
   
   i = 0
   For Each cell In Range([A1], Range("A" & Rows.Count).End(xlUp)).Cells ' перебираем ячейки в столбце А
     If Trim(cell) <> "" Then
       i = i + 1
     End If
   Next cell
   
   MsgBox "Найдено заполненных ячеек в столбце А ровно " & CStr(i) & " штук."
   
   If i <> countFiles Then MsgBox "Не совпадает число файлов с количеством заполненных ячеек!", vbCritical, "Ошибка исходных данных": Exit Sub
   i = 0
   For Each cell In Range([A1], Range("A" & Rows.Count).End(xlUp)).Cells ' перебираем ячейки в столбце А
     If Trim(cell) <> "" Then
        i = i + 1
        NewFilename = Trim(cell) & ".jpg"
        Application.StatusBar = "Обрабатывается файл  " & file_names(i) & " переименовываем в " & NewFilename  ' вывод информации в строку состояния
        'MsgBox "Обрабатывается файл  " & file_names(i) & " переименовываем в " & NewFilename
        Name SourceFolder & file_names(i) As SourceFolder & NewFilename    ' переименовать файл
     End If
   Next cell
   
   Application.StatusBar = "": Application.ScreenUpdating = True
   
End Sub

ну и дополнительные функцию, вызываемые в коде:

Option Explicit

Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", Optional ByVal InitialPath As String = "c:\") As String
    Dim PS 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


Public Function getSortedFiles(ByVal dir_path As String) As String()
    Dim Filename As String, file As Variant
    Dim i As Long, j As Long, file_names() As String, coll As New Collection, lngCnt As Long, strBuffer1 As String


    Filename = Dir(dir_path)
    While Filename <> "": coll.Add Filename: Filename = Dir: Wend

    ' Make the list of names.
    'ReDim file_names(1 To fso_folder.Files.Count)
    lngCnt = coll.Count
    ReDim file_names(1 To coll.Count)
    i = 1
    For Each file In coll
        file_names(i) = file
        i = i + 1
    Next

    ' Sort the list of files.
    ' Quicksort file_names, 1, coll.Count
    'sort array by numeric value
    For i = 1 To lngCnt
        For j = (i + 1) To lngCnt
            If UCase(file_names(i)) > UCase(file_names(j)) Then
                strBuffer1 = file_names(j)
                file_names(j) = file_names(i)
                file_names(i) = strBuffer1
            End If
        Next
    Next


    ' Return the sorted list.
    getSortedFiles = file_names
End Function

Большое спасибо за программу, буду пробовать.

Все прекрасно работает. Правда вначале выдало ошибку only comments may appear after end sub end function or end property. Но я ее поборол. Еще раз большое спасибо. Теперь мне не придется вручную 500 файлов переименовывать.