Macro para seleccionar, copiar y pegar columnas discontinuas

Partiendo de esto:

Sub SELECCIONAR2()

Sheets("hoja1).Select

Set a = Range("b17", Range("b17").End(xlDown))

Set b = Range("C17", Range("C17").End(xlDown))

Set c = Range("d17", Range("d17").End(xlDown))

Set d = Range("f17", Range("f17").End(xlDown))

Set e = Range("g17", Range("g17").End(xlDown))
Union(a, b ,c ,d, e). Select

Quiero copiar esta selección discontinua y pegarla en la hoja 2, celda m1

3 respuestas

Respuesta
2

Prueba con esta macro

Sub copiar_datos()
Set ho = Worksheets("hoja1")
Set hd = Worksheets("hoja2")
Set rango = Union(ho.Range("b17").CurrentRegion, ho.Range("f17").CurrentRegion)
With rango
    .Copy: hd.Range("m1").PasteSpecial
End With
End Sub

¡Gracias! 

Saludos James, gracias por la ayuda. James, solamente necesito que los rangos a copiar sean "B17 : D17" y "F17 , G17", como quedaría el código.

Gracias.

El código queda así

Sub copiar_datos()
Set ho = Worksheets("hoja1")
Set hd = Worksheets("hoja2")
Set rango = Union(ho.Range("b17:d17"), ho.Range("f17:g17"))
With rango
    .Copy: hd.Range("m1").PasteSpecial
End With
End Sub
Respuesta
1

Si tienes algo como esto:

Y lo quieres así:

entonces , quedaría la macro de esta forma:

Sub SELECCIONAR2()
    Sheets("hoja1").Select
    Set a = Range("b17", Range("b17").End(xlDown))
    Set b = Range("C17", Range("C17").End(xlDown))
    Set c = Range("d17", Range("d17").End(xlDown))
    Set d = Range("f17", Range("f17").End(xlDown))
    Set e = Range("g17", Range("g17").End(xlDown))
    Union(a, b, c, d, e).Copy Sheets("Hoja2").Range("M1")
End Sub

Avísame cualquier duda

.

.

Respuesta
1

Ahí te adjunto el código del desarrollo de tu consulta.

Sub CopiarRangos()
Sheets("Hoja1").Select
Dim a As Range, b As Range, c As Range, d As Range, e As Range
Set a = Range("a1", Range("a1").End(xlDown))
Set b = Range("C1", Range("C1").End(xlDown))
Set c = Range("d1", Range("d1").End(xlDown))
Set d = Range("f1", Range("f1").End(xlDown))
Set e = Range("g1", Range("g1").End(xlDown))
Set RangoUnido = Union(a, b, c, d, e)
RangoUnido.Copy
Sheets("Hoja2").Select
Range("M1").PasteSpecial
End Sub

Ander GS.

¡Gracias! 

Hola Ander gracias por la ayuda , pero cuando ejecuto la Macro aparece error en la línea de Rangounido.Copy  ¿qué pudo haber pasado?

 Sheets("datasheet").Select
    Set a = Range("b17", Range("b17").End(xlDown))
    Set b = Range("C17", Range("C17").End(xlDown))
    Set c = Range("d17", Range("d17").End(xlDown))
    Set d = Range("f17", Range("f17").End(xlDown))
    Set e = Range("g17", Range("g17").End(xlDown))
    Set RangoUnido = Union(a, b, c, d, e)
    RangoUnido.Copy
    Sheets("hoja2").Select
    Range("a4").PasteSpecial
End Sub

He ejecutado el código que proporcionaste y ejecuta bien. ¿Qué error te muestra cuando ejecutas la macro?

Te aseguraste que todos los rangos a, b, c, d y e tienen igual tamaño. Si no lo tienen entonces te muestra un error en la línea RangoUnido. Copy

Cualquier consulta estaré atento.

Ander GS

Uhmmm, los tamaños no son iguales, como haría, ya que la hoja "datasheet" es una formato predeterminado.

hola Ander, tienes razón, las columnas no tienen el mismo tamaño, como quedaría el codigo, partiendo de esa situación. 

gracias!!

Adjunto código para su revisión, considerando rangos de diferentes tamaños.

Sub CopiarRangos()
 Dim Celda As String, Rango As Range, Col(0 To 4) As String
 Col(0) = "B"
 Col(1) = "C"
 Col(2) = "D"
 Col(3) = "F"
 Col(4) = "G"
 For i = 0 To 4
    Sheets("datasheet").Select
    Celda = Col(i) & "17"
    Set Rango = Range(Celda, Range(Celda).End(xlDown))
    Rango.Copy
    Sheets("hoja2").Select
    Range("a4").Offset(0, i).PasteSpecial
Next i
End Sub

Por favor no olvidar de valorar las respuestas.

¡Gracias! 

Excelente !!! Ander!!! me haces Feliz!!! gracias.

Que bueno que te haya servido de mucho y puedas seguir avanzando con tu proyecto.

Por favor, no olvidar de valorar las respuestas.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas