Macro par importar datos de un libro a otro de excel

publicado el 3 de enero4 años

Buenos días

Podríais ayudarme a refinar esta macro que realice con la grabadora.

Gracias

Sub MetodoAbrirLibro()

Workbooks.Open "C:\Users\jctorres\Desktop\pruebas partes automaticos\C2020-0138_Carga_Horas (1)2.xls"


    Windows("PARTE DE TRABAJOS EE-II.xlsm").Activate
    Sheets(13).Range("A8:f78").Copy
    Windows("C2020-0138_Carga_Horas (1)2.xls").Activate
    Sheets("Personal").Range("A8:f78").PasteSpecial xlPasteValues
        
    Windows("PARTE DE TRABAJOS EE-II.xlsm").Activate
    Sheets(13).Range("F2").Copy
    Windows("C2020-0138_Carga_Horas (1)2.xls").Activate
    Sheets("Personal").Range("G3").PasteSpecial xlPasteValues
    
    Windows("PARTE DE TRABAJOS EE-II.xlsm").Activate
    Sheets(13).Range("I2").Copy
    Windows("C2020-0138_Carga_Horas (1)2.xls").Activate
    Sheets("Personal").Range("H3").PasteSpecial xlPasteValues
    
    Windows("PARTE DE TRABAJOS EE-II.xlsm").Activate
    Sheets(13).Range("H2").Copy
    Windows("C2020-0138_Carga_Horas (1)2.xls").Activate
    Sheets("OT1").Range("h2").PasteSpecial xlPasteValues
    
    Windows("PARTE DE TRABAJOS EE-II.xlsm").Activate
    Sheets(13).Range("H3:m3").Copy
    Windows("C2020-0138_Carga_Horas (1)2.xls").Activate
    Sheets("OT1").Range("H3:m3").PasteSpecial xlPasteValues
 
    Windows("PARTE DE TRABAJOS EE-II.xlsm").Activate
    Sheets(13).Range("l2").Copy
    Windows("C2020-0138_Carga_Horas (1)2.xls").Activate
    Sheets("OT1").Range("l2").PasteSpecial xlPasteValues
    
    Windows("PARTE DE TRABAJOS EE-II.xlsm").Activate
    Sheets(13).Range("G8:H78").Copy
    Windows("C2020-0138_Carga_Horas (1)2.xls").Activate
    Sheets("OT1").Range("G8:H78").PasteSpecial xlPasteValues

    Windows("PARTE DE TRABAJOS EE-II.xlsm").Activate
    Sheets(13).Range("J8:K78").Copy
    Windows("C2020-0138_Carga_Horas (1)2.xls").Activate
    Sheets("OT1").Range("J8:K78").PasteSpecial xlPasteValues
    
    Windows("PARTE DE TRABAJOS EE-II.xlsm").Activate
    Sheets(13).Range("M8:M78").Copy
    Windows("C2020-0138_Carga_Horas (1)2.xls").Activate
    Sheets("OT1").Range("M8:M78").PasteSpecial xlPasteValues
   
    
    Windows("PARTE DE TRABAJOS EE-II.xlsm").Activate
    Application.CutCopyMode = False


End Sub

publicado el 4 de enero4 años

@Juan Carlos torres ruiz , te dejo una solución un poco a vuelapluma... Comprueba los rangos a copiar en cada hoja, creo que los he seguido bien, pero compruebalo. Como no has subido tus archivos para ver si se puede optimizar algo más, prueba el siguiente código:

Sub MetodoAbrirLibro()
Dim rngCopy As Range, rngOT1 As Range, cel As Range, adres$
Dim wbOr As Workbook, wbDes As Workbook

Application.ScreenUpdating = False

Set wbOr = ThisWorkbook
Set wbDes = Workbooks.Open("C:\Users\jctorres\Desktop\pruebas partes automaticos\C2020-0138_Carga_Horas (1)2.xls")

With wbOr.Sheets(13)
    .Range("A8:F78").Copy wbDes.Sheets("Personal").Range("A8:F78")
    .Range("F2").Copy wbDes.Sheets("Personal").Range("G3")
    .Range("I2").Copy wbDes.Sheets("Personal").Range("H3")

    Set rngOT1 = .Range("A:M")
    Set rngCopy = Intersect(rngOT1, Union(.Range("H2"), .Range("H3:M3"), .Range("12"), .Range("G8:H78"), .Range("J8:K78"), .Range("M8:M78")))

    For Each cel In rngCopy
        adres = cel.Address
        cel.Copy wbDes.Sheets("OT1").Range(adres)
    Next cel
End With

Application.CutCopyMode = False

End Sub

publicado el 5 de enero4 años

Autor

Buenas , muchas gracias, me da un error con las celdas combinadas el resto lo hace perfecto.

te adjunto los archivos.

Gracias de buevo.

Sl2

C2020-0138_Carga_Horas (1)2.xls PARTE DE TRABAJOS EE-IIjctorres.xlsm

publicado el 5 de enero4 años

Hace 2 horas, Juan Carlos torres ruiz dijo:

Buenas , muchas gracias, me da un error con las celdas combinadas el resto lo hace perfecto.

Esto pasa por no subir los archivos...

Cambia el código del siguiente bucle a lo siguiente y prueba:

For Each cel In rngCopy
        adres = cel.Address
        wbDes.Sheets("OT1").Range(adres).FormulaR1C1 = cel.Text
Next cel

publicado el 5 de enero4 años

Autor

Toda la razón que tienes.

Ahora que he pasado la macro al archivo original , me aparece este error, y por mas que le doy vueltas no consigo ver el falloPARTE DE TRABAJOS EE-IIjctorres.xlsm

publicado el 6 de enero4 años

Hace 21 horas, Juan Carlos torres ruiz dijo:

Ahora que he pasado la macro al archivo original , me aparece este error, y por mas que le doy vueltas no consigo ver el fallo

Ese error es bastante inespecífico, aunque suele indicar que algo no encuentra. En tu caso creo que es por todos los nombres con rango que tienes. La manera de poder pasar los datos es separar el copy y el paste. Usa el siguiente código:

With wbOr.Sheets("EPYC")
    .Range("A8:F78").Copy
    wbDes.Sheets("Personal").Range("A8:F78").PasteSpecial xlPasteValues
    .Range("F2").Copy
    wbDes.Sheets("Personal").Range("G3").PasteSpecial xlPasteValues
    .Range("I2").Copy
    wbDes.Sheets("Personal").Range("H3").PasteSpecial xlPasteValues

    Set rngOT1 = .Range("A:M")
    Set rngCopy = Intersect(rngOT1, Union(.Range("H2"), .Range("H3"), .Range("l2"), .Range("G8:H78"), .Range("J8:K78"), .Range("M8:M78")))

    For Each cel In rngCopy
        adres = cel.Address
        wbDes.Sheets("OT1").Range(adres).FormulaR1C1 = cel.Text
    Next cel
End With

publicado el 6 de enero4 años

Autor

Muchas gracias , ya no da ese error.

Estoy duplicando la macro para que rellene mas hojas del archivo y me encuentro que que los datos de la celda h3 en la hoja ot2 se copia lo mismo que en la hoja ot1 .

Sub MetodoAbrirLibro()
Dim rngCopy As Range, rngOT1 As Range, cel As Range, adres$
Dim wbOr As Workbook, wbDes As Workbook

Application.ScreenUpdating = False

Set wbOr = ThisWorkbook
Set wbDes = Workbooks.Open("C:\Users\jctorres\Desktop\pruebas partes automaticos\C2020-0138_Carga_Horas (1)2.xls")

With wbOr.Sheets("EPYC")
    .Range("A8:F78").Copy
    wbDes.Sheets("Personal").Range("A8:F108").PasteSpecial xlPasteValues
    .Range("F2").Copy
    wbDes.Sheets("Personal").Range("G3").PasteSpecial xlPasteValues
    .Range("I2").Copy
    wbDes.Sheets("Personal").Range("H3").PasteSpecial xlPasteValues

    Set rngOT1 = .Range("A:M")
    Set rngCopy = Intersect(rngOT1, Union(.Range("H2"), .Range("H3"), .Range("l2"), .Range("G8:H108"), .Range("J8:K108"), .Range("M8:M108")))

    For Each cel In rngCopy
        adres = cel.Address
        wbDes.Sheets("OT1").Range(adres).FormulaR1C1 = cel.Text
    Next cel
    
    Set rngOT2 = .Range("A:u")
    Set rngCopy = Intersect(rngOT2, Union(.Range("p2"), .Range("p3"), .Range("t2"), .Range("o8:p108"), .Range("r8:s108"), .Range("u8:u108")))

    For Each cel In rngCopy
        adres = cel.Address
        wbDes.Sheets("OT2").Range(adres).FormulaR1C1 = cel.Text
    Next cel
    
     Set rngOT3 = .Range("W:AC")
    Set rngCopy = Intersect(rngOT3, Union(.Range("H2"), .Range("H3"), .Range("l2"), .Range("G8:H108"), .Range("J8:K108"), .Range("M8:M108")))

    For Each cel In rngCopy
        adres = cel.Address
        wbDes.Sheets("OT3").Range(adres).FormulaR1C1 = cel.Text
    Next cel
    
      Set rngOT4 = .Range("AE:AK")
    Set rngCopy = Intersect(rngOT4, Union(.Range("H2"), .Range("H3"), .Range("l2"), .Range("G8:H108"), .Range("J8:K108"), .Range("M8:M108")))

    For Each cel In rngCopy
        adres = cel.Address
        wbDes.Sheets("OT4").Range(adres).FormulaR1C1 = cel.Text
    Next cel
End With

Application.CutCopyMode = False

End Sub

C2020-0138_Carga_Horas (1)2.xls

publicado el 9 de enero4 años

En 6/1/2021 at 19:44 , Juan Carlos torres ruiz dijo:

Estoy duplicando la macro para que rellene mas hojas del archivo

En el archivo que has subido no está la macro ?

publicado el 9 de enero4 años

Autor

PARTE DE TRABAJOS EE-IIjctorres.xlsm

Archivado

Este tema está ahora archivado y está cerrado a más respuestas.

Ir al listado de temas

Domina Excel, de Cero a Experto

¿Atascado? Deja de buscar soluciones puntuales. Aprende a dominar Excel para siempre con nuestro curso online. Más de 115 lecciones y soporte directo.

Ver el Curso Completo

192 Archivos
99 Comentarios
30 Revisiones
Última descarga

Cómo conservar la función AHORA()
- 1

Error en Macro

Le aumenté a 3 Seg. Y nada, no se que estoy haciendo mal
Este seria la impresión original al cargar el Formulario:

Y esta es la Impresión que me sale, me carga el Saldo en la Celda J21 del Recibo

Por dorgelis, · publicado el 5 de agosto5 ago
Error en Macro

Probé la macro incluyendo la linea anterior y en mi ordenador un segundo fue suficiente para que funcionara correctamente.
Si te sigue dando el formulario incorrecto modifica el tiempo de espera de esa línea subiendo de 1 a 3 segundos.

Por Sergio, · publicado el 5 de agosto5 ago
Error en Macro

Gracias por responder, perdón por la confusión, efectivamente al imprimir me sigue colocando los montos errados al imprimir el formulario

Por dorgelis, · publicado el 5 de agosto5 ago
Error en Macro

En el mensaje original no comentabas nada de un error, simplemente no te salía el formulario con los valores que deseabas. ¿Es así?

Por Sergio, · publicado el 5 de agosto5 ago
Error en Macro

Saludos Profesor Sergio, de ante mano gracias por responder, realice lo que me sugirió coloque el código donde me indicó, sin embargo me sigue arrojando el mismo error.
' Restaurar formato de fuente
With wsHistorico.Rows("2:2").Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
' Incrementar automáticamente el número de recibo
wsRecibo.Range("J2").Value = wsRecibo.Range("J2").Value + 1
'Corrección de Error en impresión
Application.Wait (Now + TimeValue("0:00:01"))
' Imprimir
wsRecibo.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False

Por dorgelis, · publicado el 4 de agosto4 ago

No hay usuarios registrado para ver esta página.

Conéctate a Ayuda Excel

Macro par importar datos de un libro a otro de excel

Featured Replies

Archivado

Archivos

Cómo conservar la función AHORA()

Agenda v01

Gráficos de aranceles con colores difusos

Cómo crear hipervínculos inteligentes con fórmulas

Cambios en el Control Horario

Estadísticas de descargas

Mensajes

Error en Macro

Error en Macro

Error en Macro

Error en Macro

Error en Macro

Visualizado recientemente 0

Account

Navigation

Buscar

Configure browser push notifications

Chrome (Android)

Chrome (Desktop)

Safari (iOS 16.4+)

Safari (macOS)

Edge (Android)

Edge (Desktop)

Firefox (Android)

Firefox (Desktop)