yimgame

Macro Excel Renombrar archivos

Dec 8th, 2020
1,772
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Macro para excel con el fin de renombrar la lista de archivos de la columna A con los nombres de la columna B y en la columna C pone OK si renombre correctamente.
  2.  
  3. El excel con extensión para macros .xlsm deben estar en el mismo fichero de los archivos a renombrar
  4.  
  5.  
  6. La macro la insertan mediante la herramienta programador de excel que abre una instancia de visual basic e insertan un modulo en el libro, en lo posible solo tengan abierto el excel que usaran para renombrar, aunque pueden encontrarse con el libro de macros personal abierto por defecto.
  7.  
  8. Likes para el compañero Jesús Hernandez que se tomó el trabajo de hacer un video para explicar el codigo, dejó el recurso.
  9.  
  10. https://www.youtube.com/watch?v=j7wFr-siUx0&ab_channel=Jes%C3%BAsHern%C3%A1ndez
  11.  
  12.  
  13. Dim Objeto_Ficheros As Object
  14. Dim Lista_Ficheros As Object
  15. Dim Ficheros As Object
  16. Dim Fichero As Object
  17.  
  18. Sub RENOMBRAR_ARCHIVOS()
  19. '--------------------------------------------------------------
  20. Set Objeto_Ficheros = CreateObject("Scripting.FileSystemObject")
  21. Set Lista_Ficheros = Objeto_Ficheros.GetFolder(ThisWorkbook.Path & "\")
  22. Set Ficheros = Lista_Ficheros.Files
  23. '--------------------------------------------------------------
  24. x = 1
  25. While ActiveSheet.Cells(x, 1) <> ""
  26.     If ActiveSheet.Cells(x, 3) <> "OK" Then
  27.        For Each Fichero In Ficheros
  28.            If UCase(Fichero) = UCase(ThisWorkbook.Path & "\" & ActiveSheet.Cells(x, 1)) Then
  29.               Fichero.Copy ThisWorkbook.Path & "\" & ActiveSheet.Cells(x, 2), True
  30.               Fichero.Delete
  31.               ActiveSheet.Cells(x, 3) = "OK"
  32.               Exit For
  33.            End If
  34.        Next
  35.     End If
  36. x = x + 1
  37. Wend
  38. End Sub
  39.  
RAW Paste Data