Jump to content

Copiar y pegar en otro libro


Recommended Posts

Hola amigos, me pueden ayudar a solucionar este asunto, quiero copiar rangos no adyacentes de un libro a otro es decir el resumen de importes y servicios a un nuevo libro estuve buscando, pero encontré nada, anexo los archivas para la posible solución

el archivo origen se llama comparativo y el archivo destino se llama resumen

Saludos cordiales

Comparativo.rar

Link to post
Share on other sites

Abre los dos archivos en la misma instancia Excel y ejecuta la macro adjunta desde Comparativo.xlsm, la macro copia las filas amarillas al archivo Resumen.xlsx.

Sub ActualizarResumen()
Dim Resumen

Set Resumen = Workbooks("Resumen.xlsx").Sheets("Hoja1")
Range("A:O").Copy Resumen.Range("A1")
Resumen.UsedRange = Resumen.UsedRange.Value
For x = Resumen.Range("B1").End(xlDown).Row To 2 Step -1
If Not Resumen.Range("B" & x).Interior.Color = vbYellow Then
Resumen.Rows(x).Delete
End If
Next

End Sub
[/CODE]

[/b]

Link to post
Share on other sites

Abre los dos archivos en la misma instancia Excel y ejecuta la macro adjunta desde Comparativo.xlsm, la macro copia las filas con la columna B amarilla al archivo Resumen.xlsx desde Enero hasta el mes que informes al ejecutar la macro.

Option Base 1
Sub ActualizarResumen()
Dim Resumen, Letras, Total, Mes

Application.ScreenUpdating = False
Letras = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "K", "M", "N")

Do Until IsNumeric(Mes) = True And Mes > 0 And Mes < 12
Mes = InputBox("Introducir el mes HASTA del resumen." & Chr(10) & _
"Ejemplo: 1=Enero, 2=Febrero,....12=Diciembre")
Loop

Columns("A:" & Letras(CInt(Mes) + 2)).Select
Set Resumen = Workbooks("Resumen.xlsx").Sheets("Hoja1")
Resumen.Cells.Clear
Selection.Copy Resumen.Range("A1")
Total = Letras(Selection.Columns.Count + 1)
Hasta = Letras(Selection.Columns.Count)
Columns("O:O").Copy Resumen.Columns(Selection.Columns.Count + 1)
Resumen.UsedRange = Resumen.UsedRange.Value

For x = Resumen.Range("B1").End(xlDown).Row To 2 Step -1
If Not Resumen.Range("B" & x).Interior.Color = vbYellow Then
Resumen.Rows(x).Delete
End If
Next

For x = 2 To Resumen.Range("B1").End(xlDown).Row
Resumen.Range(Total & x).Formula = "=SUM(C" & x & ":" & Hasta & x & ")"
Next
Range("A1").Select
Workbooks("Resumen.xlsx").Activate
End Sub
[/CODE]

Link to post
Share on other sites

Archived

This topic is now archived and is closed to further replies.

×
×
  • Create New...

Important Information

Privacy Policy