Remonter des cellules de plusieurs colonnes au niveau des cellules d'1 autre colonneA

Bonjour,

je me permet de recréer une discussion sur ce sujet,

je souhaite faire remonter des cellules de plusieurs colonnes au niveau des cellules (non vides) d'une première colonne (colonne B).
Grace au forum, j'ai obtenu la macro ci-dessous.
Elle marche très bien, mais je souhaiterai qu'elle fonctionne que de la ligne 1 à 3000.
En effet mon fichier contient 50000 lignes de données et cette macro fonctionne sur ces 50000 lignes alors que j'en ai besoin que sur 3000 et c'est très long.
Merci de votre aide.

Sub remonter_cellule_DAP()
Application.ScreenUpdating = False
For N = 1 To 15
x = Cells(Rows.Count, N).End(xlUp).Row
If x > derlin Then derlin = x
Next
ReDim tb(0)
tablo = Range("B7:M" & derlin + 1)
For N = LBound(tablo, 1) To UBound(tablo, 1)
If tablo(N, 1) <> "" Then
tb(UBound(tb)) = N
ReDim Preserve tb(UBound(tb) + 1)
End If
Next
tb(UBound(tb)) = UBound(tablo, 1)
For N = LBound(tb) To UBound(tb) - 1
Debut = tb(N)
Fin = tb(N + 1)
For p = LBound(tablo, 2) + 1 To UBound(tablo, 2)
For q = Debut To Fin - 1
For r = Debut To q - 1
If tablo(r, p) = "" Then
tablo(r, p) = tablo(q, p)
tablo(q, p) = ""
End If
Next
Next
Next
Next
Range("B7").Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo


End Sub

Cordialement