La macro ya no funciona como debería

Tengo esta macro que no esta funcionando como debería, probando cada una de las partes funciona a la perfección pero al unirlas ya no.


Private Sub commandbutton1_click()
Hoja1.Select
Range("a2", "h300").ClearContents
'definir variables
Dim Archivo As String
Archivo = Dir("c:\datos\control de obra\*.xlsx")
Dim fila As Long
Dim fil As Long
Do While Archivo <> “”
Application.ScreenUpdating = False
Workbooks.Open "c:\datos\control de obra\" & Archivo
'copiar e insertar OT
Cells(3, 4).Copy
Application.ScreenUpdating = False
Windows("Porcentaje de Avance por Obra.xlsm").Activate
fil = Application.WorksheetFunction.CountA(Range("c:c")) + 1
Cells(fil, 1).PasteSpecial xlPasteValues
Application.ScreenUpdating = False
Windows(Archivo).Activate
'copiar e insertar datos Nombre
Cells(2, 4).Copy
Application.ScreenUpdating = False
Windows("Porcentaje de Avance por Obra.xlsm").Activate
fil = Application.WorksheetFunction.CountA(Range("c:c")) + 1
Cells(fil, 2).PasteSpecial xlPasteValues
Application.ScreenUpdating = False
Windows(Archivo).Activate
'Insertar codigo para fase
Cells(5, 2).Copy
Application.ScreenUpdating = False
Windows("Porcentaje de Avance por Obra.xlsm").Activate
fil = Application.WorksheetFunction.CountA(Range("c:c")) + 1
Cells(fil, 3).PasteSpecial xlPasteValues
Application.ScreenUpdating = False
Windows(Archivo).Activate
'copiar e insertar datos ingenieria
fila = Application.WorksheetFunction.CountA(Range("bg:bg")) + 3
Cells(fila, 59).Copy
Application.ScreenUpdating = False
Windows("Porcentaje de Avance por Obra.xlsm").Activate
fil = Application.WorksheetFunction.CountA(Range("c:c"))
Cells(fil, 5).PasteSpecial xlPasteValues
Application.ScreenUpdating = False
Windows(Archivo).Activate
'copiar e insertar datos cortes
fila = Application.WorksheetFunction.CountA(Range("bg:bg")) + 3
Cells(fila, 141).Copy
Application.ScreenUpdating = False
Windows("Porcentaje de Avance por Obra.xlsm").Activate
fil = Application.WorksheetFunction.CountA(Range("c:c"))
Cells(fil, 6).PasteSpecial xlPasteValues
Application.ScreenUpdating = False
Windows(Archivo).Activate
'copiar e insertar datos armado
fila = Application.WorksheetFunction.CountA(Range("bg:bg")) + 3
Cells(fila, 223).Copy
Application.ScreenUpdating = False
Windows("Porcentaje de Avance por Obra.xlsm").Activate
fil = Application.WorksheetFunction.CountA(Range("c:c"))
Cells(fil, 7).PasteSpecial xlPasteValues
Application.ScreenUpdating = False
Windows(Archivo).Activate
'copiar e insertar datos pintura
fila = Application.WorksheetFunction.CountA(Range("bg:bg")) + 3
Cells(fila, 427).Copy
Application.ScreenUpdating = False
Windows("Porcentaje de Avance por Obra.xlsm").Activate
fil = Application.WorksheetFunction.CountA(Range("c:c"))
Cells(fil, 8).PasteSpecial xlPasteValues
Application.ScreenUpdating = False
Windows(Archivo).Activate
'copiar e insertar datos obra
fila = Application.WorksheetFunction.CountA(Range("bg:bg")) + 3
Cells(fila, 430).Copy
Application.ScreenUpdating = False
Windows("Porcentaje de Avance por Obra.xlsm").Activate
fil = Application.WorksheetFunction.CountA(Range("c:c"))
Cells(fil, 9).PasteSpecial xlPasteValues
Application.ScreenUpdating = False
Windows(Archivo).Activate
'cierra el libro
Application.ScreenUpdating = False
ActiveWorkbook.Close savechanges:=False
Archivo = Dir
Loop
'Copia porcentaje de envios
Hoja4.Select
Range("a2", "d300").ClearContents
Archivo = Dir("c:\rebajas_envios\*.xls")
Do While Archivo <> “”
Application.ScreenUpdating = False
Workbooks.Open "c:\rebajas_envios\" & Archivo
'copiar e insertar OT
Cells(3, 3).Copy
Application.ScreenUpdating = False
Windows("Porcentaje de Avance por Obra.xlsm").Activate
fil = Application.WorksheetFunction.CountA(Range("c:c")) + 1
Cells(fil, 1).PasteSpecial xlPasteValues
Application.ScreenUpdating = False
Windows(Archivo).Activate
'copiar e insertar datos Nombre
Cells(2, 3).Copy
Application.ScreenUpdating = False
Windows("Porcentaje de Avance por Obra.xlsm").Activate
fil = Application.WorksheetFunction.CountA(Range("c:c")) + 1
Cells(fil, 2).PasteSpecial xlPasteValues
Application.ScreenUpdating = False
Windows(Archivo).Activate
'copiar e insertar datos Fase
Cells(6, 1).Copy
Application.ScreenUpdating = False
Windows("Porcentaje de Avance por Obra.xlsm").Activate
fil = Application.WorksheetFunction.CountA(Range("c:c")) + 1
Cells(fil, 3).PasteSpecial xlPasteValues
Application.ScreenUpdating = False
Windows(Archivo).Activate
'copiar e insertar datos Envios
fila = Application.WorksheetFunction.CountA(Range("ds:ds")) + 3
Cells(fila, 123).Copy
Application.ScreenUpdating = False
Windows("Porcentaje de Avance por Obra.xlsm").Activate
fil = Application.WorksheetFunction.CountA(Range("c:c"))
Cells(fil, 5).PasteSpecial xlPasteValues
Application.ScreenUpdating = False
Windows(Archivo).Activate
'cierra el libro
Application.ScreenUpdating = False
ActiveWorkbook.Close savechanges:=False
Archivo = Dir
Loop
End Sub


El problema esta en que funcionaba abriendo todos los archivos de 2 carpetas y copiando datos específicos en hojas especificas y ahora ya no lo hace.

1 Respuesta

Respuesta
2

Entiendo lo siguiente, abres un archivo, copias algunos datos y los pegas en la Hoja1 iniciando en la fila 2. Abres otro archivo, copias y pegas en la fila 3; y así sucesivamente, por cada archivo copias datos y pegas en la siguiente fila.

Lo mismo para la siguiente carpeta copias y pegas en la Hoja4.

Lo que no entendí es lo de la variable fila, busca la última fila con datos de cada archivo y le sumas 3.

Me tomé la libertad de depurar un poco tu macro, quedaría de esta forma:

Private Sub commandbutton1_click()
'Act.Por.Dante Amor
    '
    Application.ScreenUpdating = False
    '
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets(Hoja1.Name)
    Set h4 = l1.Sheets(Hoja4.Name)
    '
    h1.Range("A2:H300").ClearContents
    h4.Range("A2:D300").ClearContents
    '
    ruta1 = "c:\datos\control de obra\"
    arch1 = Dir(ruta1 & "*.xlsx")
    '
    fil = 2
    Do While arch1 <> ""
        Set l2 = Workbooks.Open(ruta1 & arch1)
        Set h2 = l2.Sheets(1)
        fila = h2.Range("BG" & Rows.Count).End(xlUp).Row + 3
        h1.Cells(fil, "A") = h2.Cells(3, 4)         'copiar e insertar OT
        h1.Cells(fil, "B") = h2.Cells(2, 4)         'copiar e insertar datos Nombre
        h1.Cells(fil, "C") = h2.Cells(5, 2)         'Insertar codigo para fase
        h1.Cells(fil, "E") = h2.Cells(fila, 59)     'copiar e insertar datos ingenieria
        h1.Cells(fil, "F") = h2.Cells(fila, 141)    'copiar e insertar datos cortes
        h1.Cells(fil, "G") = h2.Cells(fila, 223)    'copiar e insertar datos armado
        h1.Cells(fil, "H") = h2.Cells(fila, 427)    'copiar e insertar datos pintura
        h1.Cells(fil, "I") = h2.Cells(fila, 430)    'copiar e insertar datos obra
        l2.Close False  'cierra el libro
        fil = fil + 1
        arch1 = Dir()
    Loop
    '
    'Copia porcentaje de envios
    ruta2 = "c:\rebajas_envios\"
    arch2 = Dir(ruta2 & "*.xlsx")
    fil = 2
    Do While arch2 <> ""
        Set l2 = Workbooks.Open(ruta2 & arch2)
        Set h2 = l2.Sheets(1)
        fila = h2.Range("DS" & Rows.Count).End(xlUp).Row + 3
        h4.Cells(fil, "A") = h2.Cells(3, 3)         'copiar e insertar OT
        h4.Cells(fil, "B") = h2.Cells(2, 3)         'copiar e insertar datos Nombre
        h4.Cells(fil, "C") = h2.Cells(6, 1)         'copiar e insertar datos Fase
        h4.Cells(fil, "E") = h2.Cells(fila, 123)    'copiar e insertar datos Envios
        l2.Close False      'cierra el libro
        fil = fil + 1
        arch2 = Dir()
    Loop
    l1.Save
    MsgBox "Proceso terminado"
End Sub

Desde luego no tengo datos para probar ni puedo ver el resultado que esperas, pero si algo no está bien, dime qué datos tienes y cómo deberían quedar.


.

'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias

.

Avísame cualquier duda

.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas