Option Explicit
Private m_bAllFilled As Boolean
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
m_bAllFilled = False
Do
Set wks = ThisWorkbook.Worksheets(1)
With wks
Set rngToCheck = .Range("B1:B" & .Cells(.Rows.Count, 2).End(xlUp).Row)
End With
Set rngToMove = getRangeToMove(wks, rngToCheck)
Set rngToSet = getLaneRange(wks)
rngToSet.Resize(rngToMove.Rows.Count, rngToMove.Columns.Count).Value = rngToMove.Value
rngToMove.Delete shift:=xlUp
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
m_bLineLinksFilled = getLineFilled(wks, enmLine.Links)
m_bLineMitteFilled = getLineFilled(wks, enmLine.Mitte)
m_bLineRechtsFilled = getLineFilled(wks, Rechts)
With wks
If m_bAllFilled = True Then Exit Function
If .Cells(.Rows.Count, "E").End(xlUp).Row = 2 Then
Set getLaneRange = .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0)
Exit Function
ElseIf .Range("D2").Value < .Range("F2").Value And Not m_bLineLinksFilled Then
Set getLaneRange = .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0)
ElseIf .Range("D2").Value > .Range("F2").Value And Not m_bLineMitteFilled Then
Set getLaneRange = .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0)
Else
If m_bLineRechtsFilled Then Exit Function
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
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