Guten Tag

Ich hatte diese Frage bereits in einem anderen Forum gestellt, leider aber keine "Qualifizierte Antwort" erhalten. Daher der Versuch ob mir in diesem Forum geholfen werden kann.

Ich habe vor mit einem VBA den höchsten Wert in Spalte B ab B3 zu ermitteln. Damit es nicht zu lange dauert habe ich es auf B500 begrenzt.

Der größte Wert soll in "Line Mitte" (E und F) geschrieben werden (mit Name aus A) (z.B:B56 hat den höchsten Wert. nun wird A56 und B56 in die Zelle E3 und F3 geschrieben.) 

Danach der nächsthöhere Wert in Line Links. (z.B: A32 und B32 in C3und D3)

Jetzt soll immer geschaut werden wo der Nächsthöhere Wert hingeschrieben werden soll.

Das ist abhängig davon welche Line den kleineren Wert hat.

Wenn eine der Beiden Lines 20 Namen hat, soll die Jeweilige andere Line bis 20 gefüllt werden.

Wenn beide Lines voll sind, soll mit den nächsten höheren Werten die Line Rechts befüllt werden.

Zweck ist es die ersten beiden Lines mit den Höchsten Werten zu füllen und die 3. Line mit dem höchsten Rest.

Jeweils bis 20 Einträge begrenzt.

Ziel: Gruppe 1 + 2 sind etwa gleich stark und der beste Rest geht in die 3. Gruppe.


Mein Problem ist dieser Part:


Sub Max()

'


Start:

' Maximum in Spalte B finden


Dim maxB As Variant

maxB = Clear

Worksheets("Tabelle1").Activate


Set finden = Cells.Find(WorksheetFunction.Max(Range("B3:B500")), LookIn:=xlValues)

maxB = finden.Row


If maxB = 2 Then GoTo Ende


Range("A" & maxB & ":B" & maxB).Select

Selection.Copy



Im weiteren Verlauf Lösche ich nach dem Einfügen die Zellen A+B heraus damit die Spalte B neu durchsucht werden kann.


Das ganze läuft auch gut 3x durch. Dann hängt sich maxB einfach auf und bleibt bei Wert Zeile 4 hängen.

Anbei habe ich die Tabelle angehängt.


https://www.herber.de/bbs/user/139502.xlsm


Bitte helft mir.

Ich habe schon verschiedene Versionen der Maximalerkennung versucht.

Diese sind Auskommentiert in dem Makro enthalten. Meist hat dabei irgendetwas nicht funktioniert, weshalb ich auf die jetzt aktivierte Version zurückgefallen bin.


Zur Info:

Ich hatte zwischendurch immer wieder das Makro in Zwischenschritten probiert und es hatte funktioniert.


Als ich die Begrenzung auf 20 pro Spalte einprogrammiert hatte, ging das ganze den Bach runter.

Obwohl ich den Programmteil mit der Maxerkennung nicht angefasst hatte.


Ich bin jetzt nach 3 Wochen stundenlanges versuchen einfach am ende.

Wahrscheinlich ist es irgendein Dummer Fehler meinerseits den ich einfach übersehe.


Wer auch immer mir hilft, ein Stoßgebet und ein herzliches Danke sei sein Lohn.

Sub Max()
'
' Max Makro
' Suche der Gr?sten Power und Verschieben in Line Links und Mitte. wenn beide Lines 20 Teams haben, wird line Rechts mit den ?brigen der Gr??e nach gef?llt.
'
Start:
' Maximum in Spalte B finden

Dim maxB As Variant
 maxB = Clear
Worksheets("Tabelle1").Activate
'   Set finden = WorksheetFunction.Max(Range("B3:B500"))
'  Set finden = Application.WorksheetFunction.Max(ActiveSheet.Columns(2))
' Set finden = Application.WorksheetFunction.Max(ActiveSheet.Range("B3:B500"))

'maxi = WorksheetFunction.Max(Range("B3:B250"))
'maxi = WorksheetFunction.Match(maxi, Range("B3:B250"), 0) + 2


 Set finden = Cells.Find(WorksheetFunction.Max(Range("B3:B500")), LookIn:=xlValues)
 maxB = finden.Row
' maxB = maxi.Row

If maxB = 2 Then GoTo Ende

Range("A" & maxB & ":B" & maxB).Select
Selection.Copy
    
    
' Einf?gezelle ermitteln
    
Dim LetzteC As Long
Dim LetzteE As Long
Dim LetzteG As Long



With Worksheets("Tabelle1") 'Blattname anpassen
    LetzteC = .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0).Row
    LetzteE = .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0).Row
    LetzteG = .Cells(.Rows.Count, "G").End(xlUp).Offset(1, 0).Row
 End With
 EinfC = LetzteC
 EinfE = LetzteE
 EinfG = LetzteG

'auf 20 begrenzen
'Links
If EinfC > 22 And EinfE < 23 Then GoTo Lane_Mitte
'Else
'Mitte
If EinfE > 22 And EinfC < 23 Then GoTo Lane_Links
'Else
'Rechts
If EinfE > 22 And EinfC > 22 Then GoTo Lane_Rechts
' Wenn Rechts auch voll End
'If EinfC > 21 And EinfC > 21 And EinfG > 21 Then GoTo Ende
'Else
'End If


'Maximum D und F finden und vergleichen
  If Range("D2").Value < Range("F2").Value Then
  GoTo Lane_Links
 
Else
  
  GoTo Lane_Mitte
  
End If


Lane_Mitte:
' Einf?gen in Line Mitte
' Letzte Line Finden zum Einf?gen
' Einf?gen
 
    Range("E" & EinfE & ":F" & EinfE).Select
    ActiveSheet.Paste
    
    
    
' Zellen in A/B L?schen

   Range("A" & maxB & ":B" & maxB).Select
    Selection.Delete Shift:=xlUp
GoTo Next_Line


Lane_Links:
' Einf?gen in Line Links
' Letzte Line Finden zum Einf?gen
' Einf?gen
    
    Range("C" & EinfC & ":D" & EinfC).Select
    ActiveSheet.Paste
    
' Zellen in A/B L?schen

   Range("A" & maxB & ":B" & maxB).Select
    Selection.Delete Shift:=xlUp
GoTo Next_Line



Lane_Rechts:
' Einf?gen in Line Rechts
' Letzte Line Finden zum Einf?gen
' Einf?gen
 If EinfC > 22 And EinfC > 22 And EinfG > 22 Then GoTo Ende
    Range("G" & EinfG & ":H" & EinfG).Select
    ActiveSheet.Paste
    
' Zellen in A/B L?schen

   Range("A" & maxB & ":B" & maxB).Select
    Selection.Delete Shift:=xlUp
GoTo Next_Line


Next_Line:
GoTo Start

'Range("C" & EinfD & ":D" & EinfD).Select



Ende:
End



End Sub

Hier nochmal das Makro als txt:
https://www.herber.de/bbs/user/139532.txt

Ist auch imCode-Button

Danke