Iniciar sesiónCerrar
Correo:
Contraseña:
Entrar
Recordar sesión en este navegador
Iniciar sesiónIniciar sesiónCrear cuentaCrear cuenta
LWP » Foros » Excel » macro copiar archivos de subcarpetas

Excel - macro copiar archivos de subcarpetas

Volver
Nuevo Tema
<<>>
 
Vista:
sin imagen de perfil
Val: 2
Ha aumentado su posición en 11 puestos en Excel (en relación al último mes)
Gráfica de Excel

macro copiar archivos de subcarpetas

Publicado por diego (2 intervenciones) el 06/09/2018 00:37:24
Buenas tardes

tengo una estructura de carpetas a tres niveles es decir la carpeta, las subcarpetas y las sub-subcarpetas, lo que intento hacer es una macro que copie los archivos de la sub-subcarpeta a otra carpeta pero excel indica que el objeto no admite esea propiedad o método en la linea

1
For Each SubSubCarpeta In SubCarpeta.subfolder

Me podrían ayudar por favor

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Dim Ruta, Destino As String
Dim fs, Carpeta, Archivo, SubCarpeta, SubSubCarpeta As Object
Ruta = "C:\Users\User\Desktop\CarpetaA\"
Destino = "C:\Users\User\Desktop\CarpetaBase\"
Set fs = CreateObject("scripting.FileSystemObject")
Set Carpeta = fs.getfolder(Ruta)
 
 
For Each SubCarpeta In Carpeta.subfolders
    For Each SubSubCarpeta In SubCarpeta.subfolder
        For Each Archivo In SubSubCarpeta
            If LCase(Right(Archivo, 4)) = ".pdf" Then
            fs.movefile Archivo, Destino
            End If
        Next
    Next
Next
Valora esta pregunta
Me gusta: Está pregunta es útil y esta claraNo me gusta: Está pregunta no esta clara o no es útil
0
Responder
Imágen de perfil de Antoni Masana
Val: 4.908
Oro
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

macro copiar archivos de subcarpetas

Publicado por Antoni Masana (2562 intervenciones) el 07/09/2018 07:22:02
Encontre este codigo ( Buscar_Archivos(ruta) ) en una página wEB y lo adapte a mis necesidades.
Es un pelin complejo y segun que tocas deja de funcionar.
Hace exactamente lo que necesitas pero en lugar de guardar en un fichero necesitas que lo copie.
Te marco donde deberias hacer la modificación y prescindir del fichero y del proceso Buscar_PDF()

Declare las tres variables publicas porque daba error si las pasaba como parametros.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
Public c_Planti As String
Public Tipo_Ext As String
Public Files_Num As Integer
 
' </> --------------------------------------------------------------------- </>

' </> ---&---

' </> --------------------------------------------------------------------- </>

 
Sub Buscar_PDF()
    Dim c_Planti As String
 
    c_Planti = "C:\Users\User\Desktop\CarpetaA\"
 
    Open c_Planti + "Files.$$$" For Output As #9

        Files_Num = 0
        Tipo_Ext = ".pdf"
        Buscar_Archivos c_Planti
    Close #9

End Sub
 
' </> --------------------------------------------------------------------- </>

' </> ---&---                                                       ---&--- </>

' </> ---&---   U T I L I D A D E S                                 ---&--- </>

' </> ---&---                                                       ---&--- </>

' </> --------------------------------------------------------------------- </>

 
Sub Buscar_Archivos(ruta)
 
    'Sección 1: Declaración de variables y objetos

    Dim fs, carpeta, archivo, subcarpeta As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
 
    'Sección 2: Ajustes necesarios a ruta

    If ruta = "" Then
        Exit Sub
    ElseIf Right(ruta, 1) <> "" Then
        ruta = ruta & ""
    End If
 
    'Sección 3: Objeto Folder de la ruta indicada

    On Error GoTo ErrHandler
    Set carpeta = fs.GetFolder(ruta)
 
    'Sección 4: Obtener archivos del objeto Folder

    For Each archivo In carpeta.Files
        If InStr(UCase(archivo.Name), UCase(Tipo_Ext)) > 0 Then
           Print #9, ruta & "\" & archivo.Name              ' <-- Estas tres lineas son las que debes tocar

           Files_Num = Files_Num + 1
           Menu.StatusBar = "   " & Files_Num
        End If
    Next
 
    'Sección 5: Obtener subcarpetas del objeto Folder

    For Each subcarpeta In carpeta.SubFolders
        Buscar_Archivos (subcarpeta)
    Next
 
    'Sección 6: Auto-ajustar columnas y salir

    Exit Sub
 
ErrHandler:
    MsgBox "Archivo inexistente"
 
End Sub
 
' </> --------------------------------------------------------------------- </>

' </> ---&---                                                       ---&--- </>

' </> ---&---   F I N   D E   L A   M A C R O                       ---&--- </>

' </> ---&---                                                       ---&--- </>

' </> --------------------------------------------------------------------- </>

Saludos.
\\//_
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar