Copiar filas en una hoja nueva

Aqui lo tienes:

Sub copiarfilas()
Dim UltimaFilaHoja1 As Long
Dim UltimaFilaHoja2 As Long
Dim UltimaFilaHoja3 As Long
Dim UltimaFilaHoja4 As Long
Dim Fila As Long
Dim NumeroFila As Long


Dim Hoja1 As Worksheet
Dim Hoja2 As Worksheet
Dim Hoja3 As Worksheet
Dim Hoja4 As Worksheet
Dim Hoja5 As Worksheet

Set Hoja1 = Worksheets("Hoja1")
Set Hoja2 = Worksheets("Hoja2")
Set Hoja3 = Worksheets("Hoja3")
Set Hoja4 = Worksheets("Hoja4")
Set Hoja5 = Worksheets("Hoja5")

UltimaFilaHoja1 = Hoja1.Range("a65536").End(xlUp)
UltimaFilaHoja2 = Hoja2.Range("a65536").End(xlUp)
If UltimaFilaHoja2 <> UltimaFilaHoja1 Then
MsgBox "Numero de filas distinto·"
Exit Sub
End If
UltimaFilaHoja3 = Hoja3.Range("a65536").End(xlUp)
If UltimaFilaHoja2 <> UltimaFilaHoja1 Then
MsgBox "Numero de filas distinto·"
Exit Sub
End If
UltimaFilaHoja4 = Hoja4.Range("a65536").End(xlUp)
If UltimaFilaHoja2 <> UltimaFilaHoja1 Then
MsgBox "Numero de filas distinto·"
Exit Sub
End If


For Fila = 1 To UltimaFilaHoja1
NumeroFila = (Fila - 1) * 4
Hoja1.Rows(Fila).Copy Hoja5.Rows(1 + NumeroFila)
Hoja2.Rows(Fila).Copy Hoja5.Rows(2 + NumeroFila)
Hoja3.Rows(Fila).Copy Hoja5.Rows(3 + NumeroFila)
Hoja4.Rows(Fila).Copy Hoja5.Rows(4 + NumeroFila)
Next
MsgBox "finalizado"

End Sub

Hola a todos. (perdon por el reposteo, me equivoque y se

me paso hacer

hilo nuevo)

Queria saber si puedo hacer lo siguiente:
Tengo un libro con 4 hojas. Las hojas tienen identica

estructura aunque

datos diferentes. Quiero hacer una hoja nueva que tenga

las filas de las

otras cuatro ordenadas de modo que la primera fila sea la

primera de la

primera hoja, la segunda la primera de la segunda hoja, la

tercera la

primera de la tercera hoja y la cuarta la primera de la

cuarta hoja. Es

decir, una tabla que reuna todas las filas pero ordenadas

por la primera

columna de cada hoja (es una fecha). No tengo problema

para hacerlo con

la primera fila mediante esta macro que encontre, pero

solo me extrae la

primera fila, ¨como se puede repetir para todas?


Sub Test4()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long



On Error Resume Next
If Len(ThisWorkbook.Worksheets.Item("Master").Name)

0 Then

On Error GoTo 0
Application.ScreenUpdating = False
Set DestSh = Worksheets.Add
DestSh.Name = "Master"
For Each sh In ThisWorkbook.Worksheets
If sh.Name <> DestSh.Name Then
Last = LastRow(DestSh)



sh.Rows("3").Copy DestSh.Cells(Last + 1, "A")
End If
Next
Cells(1).Select
Application.ScreenUpdating = True
Else
MsgBox "The sheet Master already exist"
End If
End Sub

La funcion LastRow es:

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Lo que quiero es esto pero para la totalidad de las hojas.


Gracias de antemano. Perdon por lo extenso.


Salu2. Martin


.