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
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 SubDesde 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
.
