¿Cómo aplicar una macro a varios libros con distinto nombre ubicados en una carpeta?

Tengo el código de una macro la cual quiero aplicar a varios libros con distinto nombre ubicados en una carpeta.

1 Respuesta

Respuesta
1

[Hola 

Describe el proceso y el resultado que necesitas

Hola adriel ya tengo el código que quiero aplicar a los libros la consulta es que para no estar abriendo y cerrando todos los libros como puedo aplicar ese código a todos los libros que tengo guardado en una carpeta.

Saludos.

Pon la macro para ajustarla y explica que acción va realizar en cada hoja

Diré en cada libro

Sub Poner_Datos()

'Act.Por Dante Amor

    Application.ScreenUpdating = False

    Range("B:E").EntireColumn.Insert

    u = Range("A" & Rows.Count).End(xlUp).Row

    Range("B10:B" & u).Value = 1

    Range("C10:C" & u).Value = 2018

    Range("D10:D" & u).Formula = "=DATE(RC[-1],RC[-2],RC[-3])"

    Range("D10:D" & u).Copy

    Range("E10").PasteSpecial xlPasteValuesAndNumberFormats

    Application.CutCopyMode = False

    Range("A9").Copy

    Range("F10").PasteSpecial xlPasteValuesAndNumberFormats

    'Application.CutCopyMode = False

    Range("F11:F" & u).Value = Range("F10")

    Columns("F:F").Select

    Range("F7").Activate

    With Columns("F:F")

     .VerticalAlignment = xlBottom

      .WrapText = False

       .Orientation = 0

                .AddIndent = False

                .IndentLevel = -1

                .ShrinkToFit = False

                .ReadingOrder = xlContext

            End With

            Range("F8").FormulaR1C1 = "SUCURSAL"

            Range("E8").FormulaR1C1 = "FECHA"

            Range("B:D").EntireColumn.Delete

            Rows("9:9").Delete Shift:=xlUp

             Range("A1:A6").EntireRow.Delete

            Range("G1:K1").EntireRow.Delete

            Range("A1").Value = 1

Application.ScreenUpdating = False

On Error Resume Next

Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Range("A1").Select

Application.ScreenUpdating = True

End Sub

Va la macro

Valora la respuesta para finalizar


Aplica la macro a la primera hoja de cada libro

Sub lee_libros()
Act.Adriel Ortiz
'
Application.ScreenUpdating = False
'
ruta = "C:\CLIENTE\libros\"
ChDir ruta
archi = Dir(ruta & "*.xls*")
Do While archi <> ""
        Workbooks.Open archi
        Set l1 = ActiveWorkbook
        Set h = l1.Sheets(1)
                h.Select
                'Act.Por Dante Amor
                h.Range("B:E").EntireColumn.Insert
                u = h.Range("A" & Rows.Count).End(xlUp).Row
                h.Range("B10:B" & u).Value = 1
                h.Range("C10:C" & u).Value = 2018
                h.Range("D10:D" & u).Formula = "=DATE(RC[-1],RC[-2],RC[-3])"
                h.Range("D10:D" & u).Copy
                h.Range("E10").PasteSpecial xlPasteValuesAndNumberFormats
                Application.CutCopyMode = False
                h.Range("A9").Copy
                h.Range("F10").PasteSpecial xlPasteValuesAndNumberFormats
                'Application.CutCopyMode = False
                h.Range("F11:F" & u).Value = Range("F10")
                h.Columns("F:F").Select
                h.Range("F7").Activate
                With h.Columns("F:F")
                 .VerticalAlignment = xlBottom
                  .WrapText = False
                   .Orientation = 0
                            .AddIndent = False
                            .IndentLevel = -1
                            .ShrinkToFit = False
                            .ReadingOrder = xlContext
                        End With
                        h.Range("F8").FormulaR1C1 = "SUCURSAL"
                        h.Range("E8").FormulaR1C1 = "FECHA"
                        h.Range("B:D").EntireColumn.Delete
                        h.Rows("9:9").Delete Shift:=xlUp
                        h.Range("A1:A6").EntireRow.Delete
                        h.Range("G1:K1").EntireRow.Delete
                        h.Range("A1").Value = 1
            Application.ScreenUpdating = False
            On Error Resume Next
            h.Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
            h.Range("A1").Select
            '
            Application.DisplayAlerts = False
            l1.Save
            Workbooks(archi).Close
            Application.DisplayAlerts = True
    archi = Dir()
Loop
MsgBox "fin"
End Sub

Ajusta la ruta donde están tus libros, respetando la diagonal del final

ruta = "C:\CLIENTE\libros\"

Gracias adriel.

no olvides de valorar la respuesta [

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas