Excel, macro para copiar rango de celdas en hojas con mismo nombre en distinto libro

Aquí hay un código bastante completo y flexible, preparado a prueba de varios errores posibles.

No olvide leer atentamente las instrucciones en los comentarios iniciales

No olvide valorar la respuesta

Saludos,

Jaime

' Macros creadas por Jaime Segura

' Este código puede estar en cualquier archivo, inclusive en el libro Personal
' Para ejecutar la macro, el archivo "origen" de la información debe estar abierto
' Al seleccionar el rango de "origen" hacerlo sobre alguna hoja del archivo "origen"
' El archivo "destino" de la información debe estar cerrado
' El archivo "destino" permanece abierto al final de la macro para que el usuario
' compruebe que todo fue copiado correctamente

Option Compare Text
Option Explicit
Option Base 1

Sub Duplica()
' by Jaime Segura

On Error GoTo out

Dim rango As Range
Dim rangoTXT As String
Dim archORI As Workbook
Dim NOMBREarchDES As Variant
Dim archDES As Workbook
Dim mensaje As String
Dim titulo As String
Dim lista As String
Dim hoja As Worksheet
Dim rpta As VbMsgBoxResult
Dim hojas() As String
Dim n As Integer, i As Integer, j As Integer
Dim listaOK As String
Dim listaNO As String
Dim ori As Variant
Dim des As Variant
Dim foundDES As Boolean

' Pregunta por el rango a copiar
titulo = "Recopilación de información"
mensaje = "Seleccione el rango que desea duplicar."
Set rango = Application.InputBox(prompt:=mensaje, title:=titulo, Type:=8)
Set archORI = rango.Parent.Parent

' Valida si es correcta la elección
rangoTXT = Replace(rango.Address, "$", "")
mensaje = "El rango elegido fue " & rangoTXT & "." & vbCrLf & _
"El archivo origen es " & archORI.Name & vbCrLf & vbCrLf & _
"¿Es conforme?"
rpta = MsgBox(mensaje, vbYesNoCancel, "PREGUNTA")

If rpta <> vbYes Then cancela: Exit Sub

' Valida lista de hojas
lista = ""
n = 0
For Each hoja In archORI.Worksheets
If hoja.Visible = xlSheetVisible Then
n = n + 1
ReDim Preserve hojas(n)
hojas(n) = hoja.Name
lista = lista & vbTab & hoja.Name & vbCrLf
End If
Next hoja
mensaje = "Las hojas desde las cuales se copiaran los datos de " & rangoTXT & " son:" & vbCrLf & _
lista & vbCrLf & _
"De haberse listado alguna hoja que no desee incluir en la duplicación simplemente ocúltela en este archivo y vuelve a ejecutar la macro." & vbCrLf & _
"¿Desea continuar?"
rpta = MsgBox(mensaje, vbYesNoCancel, "PREGUNTA")
If rpta <> vbYes Then cancela: Exit Sub

' Pregunta por el archivo destino
titulo = "Navegue y seleccione el archivo destino"
NOMBREarchDES = Application.GetOpenFilename("Archivo destino *.xls?, *.xls?", , titulo, , False)
If NOMBREarchDES = False Then cancela: Exit Sub

' Valida archivo destino
titulo = "CONFIRMACIÓN FINAL"
mensaje = "El archivo seleccionado para recibir la información es " & NOMBREarchDES & "." & vbCrLf & _
"De estar todo conforme, ¿desea iniciar el proceso?"
rpta = MsgBox(prompt:=mensaje, Buttons:=vbYesNoCancel, title:=titulo)
If rpta <> vbYes Then cancela: Exit Sub

listaOK = ""
listaNO = ""

' abre el archivo destino
Workbooks.Open NOMBREarchDES
Set archDES = ActiveWorkbook

' inicializa lista de reporte
listaOK = "": listaNO = ""

' recorre las hojas del origen
For i = 1 To n
' solo actual si la hoja es visible en origen
If archORI.Sheets(hojas(i)).Visible = True Then
foundDES = False
' busca la hoja con el mismo nombre en destino
For j = 1 To archDES.Sheets.Count
If archORI.Sheets(hojas(i)).Name = archDES.Sheets(j).Name Then ' si la encuentra
ori = archORI.Sheets(hojas(i)).Range(rangoTXT).Value ' copia
archDES.Sheets(j).Range(rangoTXT).Value = ori ' pega
foundDES = True
listaOK = listaOK & vbTab & archDES.Sheets(j).Name & vbCrLf ' actualiza lista de reporte OK
End If
Next j
If Not foundDES Then
listaNO = listaNO & vbTab & archORI.Sheets(hojas(i)).Name & vbCrLf ' actualiza lista de reporte NO
End If
End If
Next i

' Informa resultados
titulo = "PROCESO TERMINADO"
mensaje = "Se copió la información hacia las hojas: " & vbCrLf & listaOK & vbCrLf
If listaNO <> "" Then
mensaje = mensaje & vbCrLf & _
"No se encontró en el archivo destino (y no se copió la información) de las hojas: " & vbCrLf & _
listaNO
End If

MsgBox prompt:=mensaje, Buttons:=vbInformation, title:=titulo

out:
End Sub

Sub cancela()
' Subrutina en caso de cancelar en el proceso de recopilación de información
Dim titulo As String
Dim mensaje As String
mensaje = "Operación cancelada."
titulo = "AVISO"
MsgBox mensaje, vbCritical, titulo
End Sub

Hola Jaime 

Gracias por compartir tu conocimiento, que ha juzgar por el fantástico resultado obtenido con tu macro, es mucho. La macro funciona perfecta. Me has ahorrado muchas horas de trabajo y te estoy sinceramente agradecido.

Un cordial saludo

Hola Jaime

¿Que código debo añadir para crear en el archivo destino las hojas que no existan y copiar en ellas toda la información de origen ?

Gracias  

Pero... en ese archivo... estas solo copiando un "rango"... ¿y todo lo demás que está en la hoja fuera de ese rango?... ¿De dónde obtienes esa información?

Suponiendo que el archivo origen tenga una nueva hoja que no esta en el destino, copiaría el contenido completo de esa hoja desde el origen sobre el destino.

Gracias

Ok.. aquí esta... con unas cuantas líneas más hace lo que deseas

' Macros creadas por Jaime Segura

' Este código puede estar en cualquier archivo, inclusive en el libro Personal
' Para ejecutar la macro, el archivo "origen" de la información debe estar abierto
' Al seleccionar el rango de "origen" hacerlo sobre alguna hoja del archivo "origen"
' El archivo "destino" de la información debe estar cerrado
' El archivo "destino" permanece abierto al final de la macro para que el usuario
' compruebe que todo fue copiado correctamente

Option Compare Text
Option Explicit
Option Base 1

Sub Duplica()
' by Jaime Segura

On Error GoTo out

Dim rango As Range
Dim rangoTXT As String
Dim archORI As Workbook
Dim NOMBREarchDES As Variant
Dim archDES As Workbook
Dim mensaje As String
Dim titulo As String
Dim lista As String
Dim hoja As Worksheet
Dim rpta As VbMsgBoxResult
Dim hojas() As String
Dim n As Integer, i As Integer, j As Integer
Dim listaOK As String
Dim listaNO As String
Dim ori As Variant
Dim des As Variant
Dim foundDES As Boolean

' Pregunta por el rango a copiar
titulo = "Recopilación de información"
mensaje = "Seleccione el rango que desea duplicar."
Set rango = Application.InputBox(prompt:=mensaje, title:=titulo, Type:=8)
Set archORI = rango.Parent.Parent

' Valida si es correcta la elección
rangoTXT = Replace(rango.Address, "$", "")
mensaje = "El rango elegido fue " & rangoTXT & "." & vbCrLf & _
"El archivo origen es " & archORI.Name & vbCrLf & vbCrLf & _
"¿Es conforme?"
rpta = MsgBox(mensaje, vbYesNoCancel, "PREGUNTA")

If rpta <> vbYes Then cancela: Exit Sub

' Valida lista de hojas
lista = ""
n = 0
For Each hoja In archORI.Worksheets
If hoja.Visible = xlSheetVisible Then
n = n + 1
ReDim Preserve hojas(n)
hojas(n) = hoja.Name
lista = lista & vbTab & hoja.Name & vbCrLf
End If
Next hoja
mensaje = "Las hojas desde las cuales se copiaran los datos de " & rangoTXT & " son:" & vbCrLf & _
lista & vbCrLf & _
"De haberse listado alguna hoja que no desee incluir en la duplicación simplemente ocúltela en este archivo y vuelve a ejecutar la macro." & vbCrLf & _
"¿Desea continuar?"
rpta = MsgBox(mensaje, vbYesNoCancel, "PREGUNTA")
If rpta <> vbYes Then cancela: Exit Sub

' Pregunta por el archivo destino
titulo = "Navegue y seleccione el archivo destino"
NOMBREarchDES = Application.GetOpenFilename("Archivo destino *.xls?, *.xls?", , titulo, , False)
If NOMBREarchDES = False Then cancela: Exit Sub

' Valida archivo destino
titulo = "CONFIRMACIÓN FINAL"
mensaje = "El archivo seleccionado para recibir la información es " & NOMBREarchDES & "." & vbCrLf & _
"De estar todo conforme, ¿desea iniciar el proceso?"
rpta = MsgBox(prompt:=mensaje, Buttons:=vbYesNoCancel, title:=titulo)
If rpta <> vbYes Then cancela: Exit Sub

listaOK = ""
listaNO = ""

' abre el archivo destino
Workbooks.Open NOMBREarchDES
Set archDES = ActiveWorkbook

' inicializa lista de reporte
listaOK = "": listaNO = ""

' recorre las hojas del origen
For i = 1 To n
' solo actual si la hoja es visible en origen
If archORI.Sheets(hojas(i)).Visible = True Then
foundDES = False
' busca la hoja con el mismo nombre en destino
For j = 1 To archDES.Sheets.Count
If archORI.Sheets(hojas(i)).Name = archDES.Sheets(j).Name Then ' si la encuentra
ori = archORI.Sheets(hojas(i)).Range(rangoTXT).Value ' copia
archDES.Sheets(j).Range(rangoTXT).Value = ori ' pega
foundDES = True
listaOK = listaOK & vbTab & archDES.Sheets(j).Name & vbCrLf ' actualiza lista de reporte OK
End If
Next j
If Not foundDES Then
listaNO = listaNO & vbTab & archORI.Sheets(hojas(i)).Name & vbCrLf ' actualiza lista de reporte NO
' COPIA LAS HOJAS QUE NO ESTABAN EN DESTINO
'DoEvents
archORI.Activate
Sheets(hojas(i)).Select
archORI.Sheets(hojas(i)).Copy after:=archDES.Sheets(archDES.Sheets.Count)
End If
End If
Next i

' Informa resultados
titulo = "PROCESO TERMINADO"
mensaje = "Se copió la información hacia las hojas: " & vbCrLf & listaOK & vbCrLf
If listaNO <> "" Then
mensaje = mensaje & vbCrLf & _
"No se encontró en el archivo destino (y se duplicaron del archivo original) las hojas: " & vbCrLf & _
listaNO
End If

MsgBox prompt:=mensaje, Buttons:=vbInformation, title:=titulo

out:
End Sub

Sub cancela()
' Subrutina en caso de cancelar en el proceso de recopilación de información
Dim titulo As String
Dim mensaje As String
mensaje = "Operación cancelada."
titulo = "AVISO"
MsgBox mensaje, vbCritical, titulo
End Sub