Copiar Y Pegar Diferentes Rangos A La Vez

[Deivid]

Hola a todos. Tengo dos hojas: HojaOrigen y HojaDestino. Quiero pasar varios rangos a la vez de la HojaOrigen a HojaDestino. Pero no me deja COPIAR varios rangos a la vez. Como lo hago? Me han comentado algo de los ARRAYS pero no se como.

Sub Pasa_Datos()
Dim fecha, Fecha2, I, I2, Encontrado, Encontrado2, mensaje
Encontrado = False
Encontrado2 = False
I = 16
Y = 24
fec = InputBox("Indica fecha para pasar los Datos: (dd-mm-aa)", "Pasar Datos diarios a Glade Furnace Data")
'Si Fec es igual a vacio(cancelar) entonces se sale de la macro
If fec = "" Then End
 
fecha = FormatDateTime(fec, vbShortDate)
Fecha2 = fecha
Do While ((Range("A" & I) <> "") And Not (Encontrado))
If (FormatDateTime(Range("A" & I).Value, vbShortDate) = fecha) Then
Encontrado = True
Else
I = I + 3
End If
Loop
If Not (Encontrado) Then
mensaje = MsgBox("Error en la fecha. Comprueba que la fecha sea correcta.", vbOKOnly, "FECHA ERRONEA")
Else
******************************************************************************** 
Range("D" & I & ":F" & I).Select
Range("G" & I & "J" & I).Select
Range("L" & I & "Q" & I).Select '''''''''''''''''''''''''''''''' AQUI ESTA MI PROBLEMA. Me gustaria seleccionar
Selection.Copy ''''''''''''''''''''''''''''''' todos los rangos a la vez. 
********************************************************************************
'Abre HojaDestino
On Error GoTo 0
Workbooks.Open ("D:\EXCEL\PLANILLAS\HojaDestino.xls")
Windows("HojaDestino.xls").Activate
Sheets("Datos").Select
Do While Range("A" & Y).Value <> "" And FormatDateTime(Range("A" & Y).Value, vbShortDate) <> Fecha2
Y = Y + 1
Loop
 
If FormatDateTime(Range("A" & Y).Value, vbShortDate) = Fecha2 Then
Range("AZ" & Y).Select
End If
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.Wait Now + TimeValue("00:00:03")
ActiveWorkbook.Save
ActiveWorkbook.Close
Windows("HojaOrigen.xls").Activate
Application.CutCopyMode = False
mensaje = MsgBox("Los datos se han pasado correctamente.", vbInformation, "PROCESO DE DATOS")
 
End If
 
End Sub

 

[Greg Truby]

No, no se puede copiar rangos con areas multiples, ni por medio de VBA ni manualmente. Hay que ir rango por rango. Eso de arrays no elimina la cosa. Si son muchos se puede cargar arrays con las direcciones y usar un bucle. Pero si son pocos (de uno a cinco), sería más fácil simplemente hacerlos uno por uno.

 

[Deivid]

Vale. Hacerlo de uno en uno es facil. Pero me gustaría ampliar los rangos de las hojas y estoy hablando de 20 a 25 rangos, quizas en un futuro sean más. Podrías indicarme en este mismo ejemplo, como se utilizarían los Arrays cargando las direcciones de estos rangos Greg?
Gracias.

 

[Greg Truby]

Uy, es que hay tantas cosas que me gustaría mejorar y no tengo tiempo en este momento. Trato de ver es puedo este fin de semana. Horita mi esposa me va a ahorcar si no salgo de oficina ya que la cena casi está.

Saludos,

 

[Deivid]

Ok Greg. Estaré atento a tu solución. Gracias por tu tiempo.
Saludos.

 

[Greg Truby]

Bueno esto todavia no es realmente como me gustaria implementar, pero no tengo mas tiempo. Es para darles unas ideas. Unos consejos: uses TAGS para identificar el tipo. Por ejemplo, el variable fecha o fec -- es una fecha o una hilera? Con strFecha y dtmFecha uno ya puede ver que strFecha es una hilera (string) y dtmFecha es DateTime.

Option Explicit
Sub Pasa_Datos()
    Dim strFecha As Date, dtmFecha As Date, _
        booEncontrado1 As Boolean, booEncontrado2 As Boolean, _
        strMensaje As String, strAddresses() As String, strList As String, _
        lngRow As Long, intCounter As Integer, _
        vAddresses As Variant
 
 
InputDate:
    strFecha = InputBox("Indica fecha para pasar los Datos: (dd-mm-aa)", "Pasar Datos diarios a Glade Furnace Data")
 
    '// Si la respuesta es nada, salir
    If Len(strFecha) = 0 Then GoTo Limpieza     '// Es muy rara vez que se usa END y termina en media rutina
 
    dtmFecha = CDate(strFecha)
    lngRow = 16
    Do Until Range("A" & lngRow) = "" Or booEncontrado1
 
        Let booEncontrado1 = (Range("A" & lngRow) = dtmFecha)
 
        lngRow = lngRow + 3
 
    Loop
    If Not booEncontrado1 Then
        If vbYes = MsgBox("Error en la fecha. Desea intentar de nuevo?", _
                          vbYesNo + vbExclamation, "FECHA ERRONEA") Then
            GoTo InputDate
        Else
            GoTo Limpieza
        End If
    End If
 
    Let strList = "D#:F#,G#:J#,L#:Q#"
    Let strList = Replace(strList, "#", CStr(lngRow))
 
    vAddresses = Split(strList, ",")
 
 
    For intCounter = LBound(vAddresses) To UBound(vAddresses)
 
        '// codigo para copiar
 
    Next intCounter
 
 
Limpieza:
    '// Area de poner objectos a nada
    '// Re-establish application settings, etc
 
Exit Sub
ErrorHander:
    '// Area para procesar errores encontrados
 
End Sub

 

[Caliche]

Deivid: aunque no le pensé mucho, de pronto el metodo "Union" para unir varios rangos antes del Copy, no le podría servir?.

Creo que vale la pena darle una miradita a este método.

Espero que le sirva de algo mi aporte.

Saludos.

caliche.

 

[Greg Truby]

¿Usted probó eso antes de escribirlo? Porque para mi esto tira error:

Public Sub foo()
    Dim r As Range
 
    Set r = Union(Range("A1"), Range("C3"))
 
    r.Copy Range("E2")
 
End Sub

 

[Deivid]

Y según este codigo Greg, porque haces el r.copy Range("E1")? Y como hago el Selection.Paste ...... de "r" ?

 

[Deivid]

Finally No. Cuando ejecuto el codigo me sale este error:

Se ha producido el error '1004' en tiempo de ejecución.
Error en el método 'Range de Objeto'_Global'