Saltar al contenido
View in the app

A better way to browse. Learn more.

Ayuda Excel

A full-screen app on your home screen with push notifications, badges and more.

To install this app on iOS and iPadOS
  1. Tap the Share icon in Safari
  2. Scroll the menu and tap Add to Home Screen.
  3. Tap Add in the top-right corner.
To install this app on Android
  1. Tap the 3-dot menu (⋮) in the top-right corner of the browser.
  2. Tap Add to Home screen or Install app.
  3. Confirm by tapping Install.

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

publicado

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]

Featured Replies

Archivado

Este tema está ahora archivado y está cerrado a más respuestas.

Configure browser push notifications

Chrome (Android)
  1. Tap the lock icon next to the address bar.
  2. Tap Permissions → Notifications.
  3. Adjust your preference.
Chrome (Desktop)
  1. Click the padlock icon in the address bar.
  2. Select Site settings.
  3. Find Notifications and adjust your preference.