Foro Excel

Hola amigos....les pido el grandisimo favor, como hago para renombrar fotos de un listado de registros el cual no coinside el orden con el nombre de las fotos el cual tiene asignado, el punto es que debe de ir a la carpeta y buscar la foto entre las N fotos que haya y renombrarla...por favor colaborenme con esto...gracias.

Hola:

Me parece que tengo algo parecido.

Mañana te digo alguna cosa.

Saludos

Antoni

Buenas Tardes:

Primero se debe agregar la referencia Microsoft Scripting 2.0 Object Library (Herramientas, Agregar Referencia)

Después tengo un método para modificar los archivos

Sub Buscar_Renombrar(Ruta As String)
Dim fso As FileSystemObject
Dim carpeta As Folder

Set fso = New FileSystemObject
Set carpeta = fso.GetFolder(Ruta)
Set Archivos = carpeta.Files

For Each archivo In Archivos
Select Case archivo.Name
Case "5004.jpg"
Name archivo.Path As Ruta & "5.jpg"
Case "3005.jpg"
Name archivo.Path As Ruta & "1.jpg"
Case "2002.jpg"
Name archivo.Path As Ruta & "3.jpg"
Case "1006.jpg"
Name archivo.Path As Ruta & "2.jpg"
Case "4032.jpg"
Name archivo.Path As Ruta & "4.jpg"
End Select
Next archivo
MsgBox "Se han renombrado los archivos!"
End Sub

Finalmente lo llamo (Tu carpeta la copie en C:\)

Private Sub Cambiar_Nombre_Click()
Buscar_Renombrar "C:\RenombrarFotos\"
End Sub

Espero te sea de utilidad

Perdon, la referencia que se debe agregar es: Microsoft Scripting Runtime

Hola:

Aprovechando la idea de Tokenring , te adjunto la macro RENOMBRAR_ARCHIVOS que hace lo siguiente:

Renombra todos los archivos de la columna 1 con el nombre de la columna 2, y deja un indicador del resultado de la operación en la columna 3 ("OK"= Operación correcta, " "=Archivo no encontrado)

Código: Seleccionar todo

Dim Objeto_Ficheros As Object
Dim Lista_Ficheros As Object
Dim Ficheros As Object
Dim Fichero As Object

Sub RENOMBRAR_ARCHIVOS()
'--------------------------------------------------------------
Set Objeto_Ficheros = CreateObject("Scripting.FileSystemObject")
Set Lista_Ficheros = Objeto_Ficheros.GetFolder(ThisWorkbook.Path & "\")
Set Ficheros = Lista_Ficheros.Files
'--------------------------------------------------------------
x = 1
While ActiveSheet.Cells(x, 1) <> ""
    If ActiveSheet.Cells(x, 3) <> "OK" Then
       For Each Fichero In Ficheros
           If UCase(Fichero) = UCase(ThisWorkbook.Path & "\" & ActiveSheet.Cells(x, 1)) Then
              Fichero.Copy ThisWorkbook.Path & "\" & ActiveSheet.Cells(x, 2), True
              Fichero.Delete
              ActiveSheet.Cells(x, 3) = "OK"
              Exit For
           End If
       Next
    End If
x = x + 1
Wend
End Sub


Nota: El libro que contenga esta macro y los archivos a renombrar, deben estar en el mismo directorio

Salu2 a to2....to2

Antoni

Muhcas gracias a ambos Tokenring y Antoni pero le pregunto a Tokenring en tu ejemplo utilizas CASE pero en modo ejemplo coloque estas 5 fotos, como le hago cuando no sean 5 sino N FOTOS (cantidad no defininda de fotos a renombrar), disculpa que les pregunte nuevamente pero es que soy novato y no logro ponerlo a funcionar......por su antencion a ambos mil gracias.

Hola:

Ayer decía:

Aprovechando la idea de Tokenring , te adjunto la macro RENOMBRAR_ARCHIVOS que hace lo siguiente:

Renombra todos los archivos de la columna 1 con el nombre de la columna 2, y deja un indicador del resultado de la operación en la columna 3 ("OK"= Operación correcta, " "=Archivo no encontrado)

Además de novato, no lees lo que te contestan

Mi respuesta, hace exactamente lo que pides.

Salu2

Antoni

Hola Antoni.....disculpa mi falta de atencion, esta muy bien, muchas gracias.

Hola, Antoni gracias por el código a mi me ha ayudado mucho; ya que mis conocimientos de VBA son casi nulos.
Tengo un problema, sabrías decirme como hacer lo mismo pero teniendo en una columna la ruta de los ficheros. Yo tengo que renombrar unos mil archivos pero en diferentes carpetas.
Gracias, un saludo

Hola sach:

Te adjunto archivo con una macro para renombrar ficheros de distintos directorios.

Saludos.

Hola Antoni

Gracias, funciona de maravilla me has salvado...... Creo que ni en cien años lo sacaría. He puesto:

Sub RenombrarFicheros()
Application.ScreenUpdating = False
Range("A2").Activate
Do Until ActiveCell = ""
Application.StatusBar = ActiveCell & ActiveCell.Offset(0, 1) & " por " & ActiveCell.Offset(0, 2)
ActiveCell.Offset(0, 3) = "Error"
On Error GoTo Notfound
Name ActiveCell & ActiveCell.Offset(0, 1) As ActiveCell & ActiveCell.Offset(0, 2)
ActiveCell.Offset(0, 3) = "OK"
Notfound:
ActiveCell.Offset(1, 0).Activate
Loop
Application.StatusBar = ""
End Sub

Que tal, un saludote desde México....Navegando un buen rato me encontre con este foro y quiero agradecer la macro que publico Antoni, corre de lujo y en lo personal me ayudo bastante, ademas veo que tienen un buen de temas por lo que seguramente no sera la unica vez que estemos en contacto.
Saludos y gracias de nueva cuenta.