Macro excel para copiar jpg

hola

tengo esta macro modificada por dante amor

Sub copiar_jpg()
'Mod.Por.DAM
    Dim Celda As Excel.Range
    ruta = ThisWorkbook.Path & "\"
    With CreateObject("Scripting.FileSystemObject")
        For Each Celda In Range("b4:b13")
            If Celda <> "" Then
                DirFile = Dir(ruta & Celda)
                If DirFile <> "" Then
                    .CopyFile ruta & "1\" & Celda, ruta & "proyeccion\" & Celda
                End If
                Set carpeta = .getfolder(ruta & "1")
                For Each subcarpeta In carpeta.subfolders
                    subsc = subcarpeta.Name
                    DirFile = Dir(subcarpeta & "\" & Celda)
                    If DirFile <> "" Then
                        .CopyFile subcarpeta & "\" & Celda, ruta & "proyeccion\" & Celda
                    End If
                Next
            End If
        Next Celda
    End With
End Sub

Necesitaria que solo copiara los jpg que yo quiera marcando con una x en la columna "N" , la X estaria en la misma fila.

gracias de antemano

2 Respuestas

Respuesta
1

Te anexo la macro con el cambio

Sub copiar_jpg()
'Mod.Por.DAM
    Dim Celda As Excel.Range
    ruta = ThisWorkbook.Path & "\"
    With CreateObject("Scripting.FileSystemObject")
        For Each Celda In Range("b4:b13")
            If Celda <> "" And UCase(Cells(Celda.Row, "N")) = "X" Then
                DirFile = Dir(ruta & Celda)
                If DirFile <> "" Then
                    .CopyFile ruta & "1\" & Celda, ruta & "proyeccion\" & Celda
                End If
                Set carpeta = .getfolder(ruta & "1")
                For Each subcarpeta In carpeta.subfolders
                    subsc = subcarpeta.Name
                    DirFile = Dir(subcarpeta & "\" & Celda)
                    If DirFile <> "" Then
                        .CopyFile subcarpeta & "\" & Celda, ruta & "proyeccion\" & Celda
                    End If
                Next
            End If
        Next Celda
    End With
End Sub

Saludos.Dante Amor

No olvides valorar la respuesta.

Respuesta

·

Si quieres mantener al máximo la macro tal como está, solo debes cambiar esta línea

If Celda <> "" Then

por esta otra

If Celda <> "" and LCase(cells(Celda.Row,"N"))="x" Then

·

Y eso es todo.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas