Buscar archivos a partir de valores de celda, copiarlos y pegarlos en otra carpeta

Saúl Armendáriz Herrera · el 7 de diciembre

Que tal a todos.

Yo soy nuevo en esto de la programación en VBA, llevo 2 semanas programando y me aventure

por un problema que tiene mi papa de estar buscando archivo por archivo y cada uno copiarlo

manualmente de una carpeta a otra...

Lo que hice fue crear un programa en donde te manda un Msgbox en donde te pide la carpeta

origen de los archivos y la carpeta destino de los archivos, los graba en A1 y B1 para después

usar esos valores. Luego en columna C, en forma decendente, se ponen los nombres de los

archivos que tiene que buscar y copiar de carpeta a carpeta....

Mi petición sería ver como hacerlo mas eficiente el programa porque a veces se cicla el programita o

tarda demasiado.

P.D. Todo el codigo lo puse junto dentro de un UserForm

Private Sub UFAgregar_Click()

'nuevo

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

Application.EnableEvents = False

ActiveSheet.DisplayPageBreaks = False

'nuevo



Dim ws As Worksheet

Set ws = Worksheets(1)



If Trim(Me.UFOrigen.Value) = "" Then

  Me.UFOrigen.SetFocus

  MsgBox "Debe ingresar un nombre"

  Exit Sub

End If



If Trim(Me.UFDestino.Value) = "" Then

  Me.UFDestino.SetFocus

  MsgBox "Debe ingresar un nombre"

  Exit Sub

End If



ws.Cells(1, 1) = Me.UFOrigen.Value

ws.Cells(1, 2) = Me.UFDestino.Value



'Aqui empieza el codigo de la macro de copiar

Dim FSO As New Scripting.FileSystemObject

Dim strcarpetainicio$, strcarpetafinal$

Dim carpeta As Folder

Dim archivo As File

Dim x As Integer



'Dim archivos As Folder

'Dim documento As String

Sheets("HOJA1").Select

Range("C1").Select





Do Until IsEmpty(ActiveCell)





Let documento = "*" + ActiveCell.Value + "*"



Let strcarpetainicio$ = ws.Cells(1, 1): Let strcarpetafinal$ = ws.Cells(1, 2)





Set FSO = CreateObject("Scripting.FileSystemObject")

Set carpeta = FSO.GetFolder(strcarpetainicio$)

Set archivos = carpeta.Files





Do



For Each archivo In archivos

If x = 2 Then Exit Do

If archivo.Name Like documento = True Then

x = x + 1

FileCopy strcarpetainicio$ & "\" & archivo.Name, strcarpetafinal$ & "\" & archivo.Name



End If



'MsgBox archivo.Name

Next archivo



Loop



Set FSO = Nothing

Set carpeta = Nothing

Set archivos = Nothing

Set documento = Nothing



x = 0

ActiveCell.Offset(1, 0).Select

Loop

'Aqui termina el codigo de copiado


Me.UFOrigen.Value = ""

Me.UFDestino.Value = ""



Unload Me

'nuevo



Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic

Application.EnableEvents = True

ActiveSheet.DisplayPageBreaks = True

Application.CutCopyMode = False

'nuevo



End Sub





Private Sub UFCerrar_Click()

Unload Me

End Sub



Private Sub UserForm_Click()



End Sub

[/CODE]