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
|