Mover Rango de Celdas y Copiar 2

Para: Dante Amor

Buenos días, Dante, necesito agregar una modificacion a su macro, la cual adjunto. La misma compara 1000 filas entre si y copia en la hoja 2 los resultados, dado que estoy realizando un proyecto en el cual la comparación supera las 2000 filas necesito realizar las siguientes modificaciones:

1) Que la macro me permita al inicio colocar el numero de filas que voy na comparar

2) Que se ejecute la macro comparando todas las filas entre si (tal como lo hace ahora)

3) Pero dado la enorme cantidad de datos que va a manejar que esos datos se puedan copiar en la hoja 2 o en varias (lo ideal seria en la hoja 2 pero es indistinto)

Sub CompararDatos()
'Por.Dante Amor
Dim iniTime!
iniTime = Timer
Application.ScreenUpdating = False
Set h1 = Sheets("Hoja1")
Set h2 = Sheets("Hoja2")
h2.Cells.Clear
n = 0
For i = 1 To 50
For j = Columns("D").Column To Columns("W").Column
Set r = h1.Range("D1:W50")
Set b = r.Find(h1.Cells(i, j), lookat:=xlWhole)
If Not b Is Nothing Then
celda = b.Address
Do
If b.Row <> i Then
h2.Cells(b.Row + n, j) = b.Value
End If
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> celda
End If
Next
h2.Rows(i + n).Delete
If wcol = 4 Then wcol = 6 Else wcol = 4
h2.Range(h2.Cells(n + 1, "D"), h2.Cells(n + 49, "W")).Interior.ColorIndex = wcol
n = n + 49
Next
MsgBox "Proceso terminado en " & Format(Timer - iniTime, "0.00 seg")
End Sub