Cambiar de nombres a archivos de fotos

[Alejandro Delgado]

Tengo dos columnas donde A1 es el nombre actual del archivo ejemplo

D:\descargas\fotos\fotos1\fotos descripción\jmazpo1401085892981.jpg

y el B1 el nombre que quiero cambiar ejemplo

D:\descargas\fotos\fotos1\fotos descripción\FoDe__1_2.jpg

tengo mas de dos mil cambios semanales que hacer espero me puedan ayudar

[ABOHORQUEZ]

Debes adjuntar un ejemplo para poder ayudarte mas facilmente.

saludos.

[Quetzal Chapa]

Buen dia Alejandro.

Tengo este archivo que te podria servir.

Comenta si te es de utilidad.

Saludos......

listar y renombrar archivos2.zip

[Alejandro Delgado]

Muchas gracias Quetzal Funciona perfecto

[Alejandro Delgado]

Quetzal una pregunta por que al copiar la macro de tu pagina a la mía antes de modificar la ejecuto y me da error soy nuevo en esto de las macros adjunto pantalla a ver si me ayudas ademas este es el código copiado tal cual

Option Explicit

Public Sub RecursiveDir(ByVal CurrDir As String, Optional ByVal Level As Long)

Dim Dirs() As String

Dim NumDirs As Long

Dim FileName As String

Dim PathAndName As String

Dim i As Long

' Make sure path ends in backslash

If Right(CurrDir, 1) <> "\" Then CurrDir = CurrDir & "\"

' Put column headings on active sheet

Cells(4, 1) = "Directorio"

Cells(4, 2) = "Nombre Archivo"

Cells(4, 3) = "Tamaño"

Cells(4, 4) = "Fecha/Hora"

Range("A4:4").Font.Bold = True

' Get files

FileName = Dir(CurrDir & "*.*", vbDirectory)

Do While Len(FileName) <> 0

If Left(FileName, 1) <> "." Then 'Current dir

PathAndName = CurrDir & FileName

If (GetAttr(PathAndName) And vbDirectory) = vbDirectory Then

'store found directories

ReDim Preserve Dirs(0 To NumDirs) As String

Dirs(NumDirs) = PathAndName

NumDirs = NumDirs + 1

Else

'Write the path and file to the sheet

ActiveSheet.Hyperlinks.Add Anchor:=Cells(LastInColumn(Range("A1")) + 1, 1), _

Address:=CurrDir, TextToDisplay:=CurrDir

ActiveSheet.Hyperlinks.Add Anchor:=Cells(LastInColumn(Range("B1")) + 1, 2), _

Address:=PathAndName, TextToDisplay:=FileName

' Cells(LastInColumn(Range("A1")) + 1, 1) = _

' CurrDir

' Cells(LastInColumn(Range("B1")) + 1, 2) = _

' FileName

Cells(LastInColumn(Range("C1")) + 1, 3) = _

FileLen(PathAndName)

Cells(LastInColumn(Range("D1")) + 1, 4) = _

FileDateTime(PathAndName)

End If

End If

FileName = Dir()

Loop

' Process the found directories, recursively

For i = 0 To NumDirs - 1

RecursiveDir Dirs(i), Level + 2

Next i

End Sub

Sub ListadoArch()

With Application.FileDialog(msoFileDialogFolderPicker)

'Siguiente linea para el caso de que se quiera tener un directorio origen

' .InitialFileName = Application.DefaultFilePath & "\"

.Title = "Selecciona el directorio donde estan los archivos a listar"

.Show

If .SelectedItems.Count = 0 Then

MsgBox "Cancelado"

Exit Sub

Else

'Borra información anterior

If LastInColumn(Range("A1")) > 4 Then

Range(Cells(5, 1), Cells(LastInColumn(Range("A1")), 1)).EntireRow.Delete

End If

Call RecursiveDir(.SelectedItems(1))

End If

End With

End Sub

[Quetzal Chapa]

Buenas tardes.

Lo que te marca error es que hace un llamado a la funcion LastInColumn, esta funcion regresa el ultimo renglon que tiene información.

Puedes sustituir la funcion por el rango que deseas o puedes incluirla, pega el codigo al final despues del End Sub.

Function LastInColumn(rng As Range)

'  Returns the contents of the last non-empty cell in a column

    Dim LastCell As Range

    Application.Volatile

    With rng.Parent

        With .Cells(.Rows.Count, rng.Column)

            If Not IsEmpty(.Value) Then

                LastInColumn = .Row

            ElseIf IsEmpty(.End(xlUp)) Then

                LastInColumn = ""

            Else

                LastInColumn = .End(xlUp).Row

            End If

        End With

    End With

End Function

[/CODE]

Saludos....

[Alejandro Delgado]

Buenas tardes

muchas gracias de nuevo se resolvió el problema muy buen foro, me salvaste

[Alejandro Delgado]

tema solucionado