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
|