Problema de pegado

Hola, disculpa la pregunta pero no encuentro la solución al error de esta macro. Se trata de un copiado y un pegado de una hoja a otra, pero me da el error de que el área copiada no es la misma que la pegada. Ayudame please.
Aquí coloco una copia de la macro:
De ante mano muchas gracias.
Sub COPIARYPEGAR()
Application.ScreenUpdating = False
Dim R As Range
Dim micolor
Dim S1, S2, X, L
S2 = "HISTORIAL"
L = 2
S1 = ActiveSheet.Name
Worksheets(S1).Select
Range("B6").Select
Selection.CurrentRegion.Select
micolor = 1
If Cells(6, 2) <> "" Then
For Each R In Selection
If R.Font.ColorIndex = micolor Then
R.EntireRow.Copy
Worksheets(S2).Select
Cells(2, 2).Activate
Do While ActiveCell <> ""
ActiveCell.Offset(L, 0).Activate
Loop
ActiveCell.Offset(0, 0).Select
Worksheets(S2).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Worksheets(S1).Select
End If
Next
Cells(5, 1).Activate
Range("B6:BE2000").ClearContents
Else
MsgBox "NO HAY NADA QUE COPIAR...", vbOKOnly
End If
Application.ScreenUpdating = True
End Sub