Complementar macro para copiar rangos

temp01 · el 12 de febrero

Buenos días tengo la siguiente macro.

La idea es copiar rangos de todas las hojas a la Hoja1 una debajo de otra.

ésta es la macro solo me funciona en la primera copia, estaré agradecido.

Sub copiar()
    Set h1 = Sheets("Hoja1") ' hoja principal
    '
    dato = Array("C1:D5", "A1:B5", "H1:I5")
    '
    For Each h In ThisWorkbook.Sheets
    If h.Name <> h1.Name Then
        u = h1.Range("A" & Rows.Count).End(xlUp).Row
        For j = LBound(dato) To UBound(dato)
             h.Range(dato(j)).Copy h1.Range("A" & u)
             u = u + 1
        Next j
    End If
    Next h
End Sub

MACRO COPIAR.xlsm

bigpetroman · el 12 de febrero

saludos @temp01, en tu macro, donde tienes

u = u +1

coloca esto

u = u + h.Range(dato(j)).Rows.Count

y listo, suerte

temp01 · el 13 de febrero

asssu acertado tu respuesta gracias

temp01 · el 13 de febrero

Hola pero tengo otra duda que cada rango pertenece a una hoja como sería ?

intenté así

Sub copiar()
    Set h1 = Sheets("Hoja1") ' hoja principal
    '
    hoja = Array("Hoja2", "Hoja3", "Hoja4")
    dato = Array("A1:B5", "C1:D5", "H1:I5")
    '
    For Each h In ThisWorkbook.Sheets
    
        If h.Name <> h1.Name Then
            u = h1.Range("A" & Rows.Count).End(xlUp).Row
            '
            For i = LBound(hoja) To UBound(hoja)
                For j = LBound(dato) To UBound(dato)
                     h(i).Range(dato(j)).Copy h1.Range("A" & u)
                     u = u + h.Range(dato(j)).Rows.Count
                Next j
            Next i
            '
        End If
    
    Next h
End Sub