so:

Hatte Zeit und Lust :)

Option Explicit
'
Private m_bAllFilled As Boolean 'Wenn allesamt gefüllt, dann true, dann Code beenden.
    Dim m_bLineLinksFilled As Boolean
    Dim m_bLineMitteFilled As Boolean
    Dim m_bLineRechtsFilled As Boolean

Enum enmLine
    Links
    Mitte
    Rechts
End Enum

Sub main()
    Dim wks As Excel.Worksheet
    Dim rngToCheck As Excel.Range
    Dim rngToMove As Excel.Range
    Dim rngToSet As Excel.Range
    '*** ist zwar False, aber der Lesbarkeit dienlich
    m_bAllFilled = False

    Do
        '*** Referenz aufs Arbeitsblatt
        Set wks = ThisWorkbook.Worksheets(1)
        With wks
            Set rngToCheck = .Range("B1:B" & .Cells(.Rows.Count, 2).End(xlUp).Row)
        End With
        '*** Ermittele Range-Objekte
        Set rngToMove = getRangeToMove(wks, rngToCheck)
        Set rngToSet = getLaneRange(wks)
        '*** Bewege Daten in Line und entferne Quelle
        rngToSet.Resize(rngToMove.Rows.Count, rngToMove.Columns.Count).Value = rngToMove.Value
        rngToMove.Delete shift:=xlUp
        '*** verlasse Schleife wenn alle Lines mit 20 Einträgen gefüllt
        '*** Füllstand einer ermitteln
        m_bLineLinksFilled = getLineFilled(wks, enmLine.Links)
        m_bLineMitteFilled = getLineFilled(wks, enmLine.Mitte)
        m_bLineRechtsFilled = getLineFilled(wks, Rechts)
        '***
        If m_bLineLinksFilled And m_bLineMitteFilled And m_bLineRechtsFilled Then
            m_bAllFilled = True
        End If
    Loop While Not m_bAllFilled = True
 
End Sub

Function getRangeToMove(wks As Excel.Worksheet, rngScope As Excel.Range) As Variant
        Dim rng As Excel.Range
    With Application
        Dim dblR%: dblR% = .Match(.Max(rngScope), rngScope, 0)
        Set rng = wks.Range(wks.Cells(dblR, 1), wks.Cells(dblR, 2))
        Set getRangeToMove = rng
    End With
End Function

Function getLaneRange(wks As Excel.Worksheet) As Excel.Range
        
        '*** Füllstand einer ermitteln
        m_bLineLinksFilled = getLineFilled(wks, enmLine.Links)
        m_bLineMitteFilled = getLineFilled(wks, enmLine.Mitte)
        m_bLineRechtsFilled = getLineFilled(wks, Rechts)
        
    With wks
        '*** prüfe, ob alle Lines bereits gefüllt
        If m_bAllFilled = True Then Exit Function
        '*** Wenn noch nichts in Line Mitte
        If .Cells(.Rows.Count, "E").End(xlUp).Row = 2 Then
            Set getLaneRange = .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0)
            Exit Function 'Return
        '*** Wenn Summe(Line Links) KLEINER Summe(Line Mitte) UND Links noch keine 20Einträge
        ElseIf .Range("D2").Value < .Range("F2").Value And Not m_bLineLinksFilled Then
            '*** Move Range Line Links
            Set getLaneRange = .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0)
        ElseIf .Range("D2").Value > .Range("F2").Value And Not m_bLineMitteFilled Then
            '*** Move Range Line Mitte
            Set getLaneRange = .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0)
        Else
            '*** vorab: Wenn Rechts voll; Exit
            If m_bLineRechtsFilled Then Exit Function
            '*** Wenn Links oder Mitte voll; prüfen wer und auffüllen
            If m_bLineLinksFilled Xor m_bLineMitteFilled = True Then
                If Not m_bLineLinksFilled Then
                    Set getLaneRange = .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0)
                    Exit Function
                End If
                
                If Not m_bLineMitteFilled Then
                    Set getLaneRange = .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0)
                    Exit Function
                End If
            End If
            '*** Move Lane Rechts; da nicht anderes mehr möglich
            Set getLaneRange = .Cells(.Rows.Count, "G").End(xlUp).Offset(1, 0)
        End If
    End With
End Function

Function getLineFilled(wks As Excel.Worksheet, Line As enmLine) As Boolean
    Select Case Line
        Case enmLine.Links
            getLineFilled = Application.CountBlank(wks.Range("C3:C1048576")) = (1048576 - 22)
        Case enmLine.Mitte
            getLineFilled = Application.CountBlank(wks.Range("E3:E1048576")) = (1048576 - 22)
        Case enmLine.Rechts
            getLineFilled = Application.CountBlank(wks.Range("G3:G1048576")) = (1048576 - 22)
    End Select
End Function