Kennzeichnung gestrichener Ergebnisse in einer "intelligenten" Wettkampftabelle

[Bödefeld]

Danke Ralf.

Jetzt gibt es wohl nichts mehr auszusetzen und ich habe mal wieder etwas dazugelernt

Viele Grüße
Bernd

[Bödefeld]

Hallo Ralf,

nun habe ich doch noch etwas gefunden.
Die bedingte Formatierung in Spalte M (Kennzeichnung Gold, Silber, Bronze) habe ich über die gesamte Spalte laufen lassen.
Wie löst man das, adäquat zu Deinem letzten Vorschlag für die Zeile 2, in einer intelligenten Tabelle?

Viele Grüße
Bernd

[Bödefeld]

Du hast da ja eine ausgeblendete Hilfsspalte in der Tabelle, die ja nicht (mehr) benötigt wird.
Wenn Du sie löscht, ermittelst Du den (für Zeilen und auch Spalten dynamischen) Bereich E:"letzterWettkampf" folgendermaßen.

Sub RPP()
Dim Challenge As Range
With Tabelle1.Range("Tabelle1")
   Set Challenge = Range(.Columns(5), .Columns(.Columns.Count - 2))
End With
Debug.Print Challenge.Address
End Sub

Hallo RPP63,
Ich habe mir Deinen Vorschlag angeschaut.
Auf die Hilfsspalte würde ich gern verzichten.
Leider verstehe ich Deinen Hinweis überhaupt nicht.
Ich bin noch nicht so weit in VB vorgedrungen.

Könntest Du mir bitte erklären, was ich nun tun soll?

Viele Grüße
Bernd

[Rabe]

Hi Benrd,

Die bedingte Formatierung in Spalte M (Kennzeichnung Gold, Silber, Bronze) habe ich über die gesamte Spalte laufen lassen.
Wie löst man das, adäquat zu Deinem letzten Vorschlag für die Zeile 2, in einer intelligenten Tabelle?

Du schreibst analog zu den Formeln in die bedingte Formatierung bei "bezieht sich auf" rein: =$M$4:$M$35
Das verlängert sich dann auch mit jeder zugefügten Zeile der iT.

[Bödefeld]

Hallo Ralf,

Danke, das habe ich jetzt für alle bedingten Formatierungen so durchgezogen und es klappt sogar.
Übrigens, man kann die Formeln der Zeile 2 doch nach rechts ziehen.
Man muss dann nur noch die Spaltennamen ändern (und die Tabellen-Nummer, wenn man die Formel auf ein anderes Blatt überträgt).
Geht m.M.n. besser, als den Bereich jedes mal aufzuziehen.

Jetzt habe ich nur noch das Problem mit der Hilfsspalte und ("RPP63") Ralfs Antwort dazu.
Mal sehen, vielleicht klärt sich das auch noch dieses Wochenende.

Viel Spaß am Wochenende
Bernd

[RPP63]

So, ich hatte jetzt Zeit.
Aufbauend auf Fenneks Code folgt hier ein Ereignismakro, welches automatisch bei Neueinträgen in die Liste startet.
Das Makro gehört ins Klassnmodul der Tabelle.
Rechtsklick auf Tabellenreiter, Code anzeigen.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Challenge As Range
Dim Anz&, j&, M&, Sp&
If Target.Count > 1 Then Exit Sub
With Me.Range("Tabelle1")
  Set Challenge = Range(.Columns(5), .Columns(.Columns.Count - 2))
End With
If Not Intersect(Target, Challenge) Is Nothing Then
  With Target
     Anz = WorksheetFunction.Count(Challenge.Rows(.Row - 3))
     If Anz > 4 Then
        With Challenge.Rows(.Row - 3)
           .Borders(xlDiagonalUp).LineStyle = xlNone
           .Borders(xlDiagonalDown).LineStyle = xlNone
        End With
        For j = 1 To Anz - 4
           M = WorksheetFunction.Small(Challenge.Rows(.Row - 3), j)
           Sp = WorksheetFunction.Match(M, Challenge.Rows(.Row - 3), 0)
           With Cells(.Row, 4 + Sp)
              .Borders(xlDiagonalUp).LineStyle = xlContinuous
              .Borders(xlDiagonalDown).LineStyle = xlContinuous
              .Borders(xlDiagonalDown).Color = -16776961
              .Borders(xlDiagonalDown).Weight = xlMedium
           End With
        Next j
     End If
  End With
End If
End Sub

Datei im Anhang.

Gruß Ralf

[Bödefeld]

Hallo Ralf (der andere),

Vielen Dank für Deine Hilfe.
Dein Script hat aber leider doch noch einen bug.
Wenn Du sortierst (z.B. nach "Rang"-Spalte "M") , werden die alten Kreuze nicht gelöscht und es kommt zu einen Kompilierfehler bei weiteren Eingaben.

Ich habe mal Dein Script in unseren aktuellen Arbeitsstand der Tabelle eingearbeitet und dann sortiert.
Du siehst das Problem in "ErgebnislisteRPP.xlsm" im Anhang.

Anbei auch meinem aktuellen Stand ("Ergebnisliste aktuell.xlsm").
Hier habe ich den Fehler mit den Kreuzen, der bei Dir noch auftritt, bereits beseitigt.
Zusätzlich dazu habe ich die durchkreuzten Felder noch mit einer hellgelben Füllung versehen.
An meiner Version gibt es aber noch 2 Probleme zu lösen:

1. Die Hilfsspalte sollte wegrationalisiert werden
   

1. Nach jedem Sortieren werden die Kreuze erst gelöscht, wenn eine neue Eingabe in die Ergebnisfelder erfolgt ist.
   Das ist unschön.
   Die Ausführung des Makros "nur_4" habe ich im Objekt "Workbook" mit der Procedur "SheetChange" vereinbart, Das Makro "nur_4" selbst als Modul.
   Hier liegt wohl der Fehler, weiß aber nicht wie.
   

Vielleicht kannst Du mir bitte helfen, aus beiden Versionen eine endgültige zu erstellen?


PS.: "meine" Version bedeutet natürlich, die Version, die durch Mithilfe des Forums entstanden ist!
Grüße
Bernd

[Bödefeld]

Hallo Ralf "RPP63"

kannst Du Dir bitte noch einmal Dein letztes Ereignismakro anschauen.
Da sind noch zwei Fehler drin:

1. Beim Sortieren werden die Kreuze nicht mit verschoben und
   
2. die Teilnehmer mit 0 Punkten sollten alle auf den letzten Platz gesetzt werden (im Beispiel Platz 25)
   

Könntest Du das bitte noch ausbessern?
Du würdest mir damit wirklich einen großen Gefallen tun.

Viele Grüße und ein schönes Wochenende
Bernd
[/list]

[Bödefeld]

Hallo,

leider kann mir RPP63 anscheinend nicht mehr helfen.
deshalb das Problem noch einmal an alle hier im Forum:
Das Programm erfasst Sportergebnisse, wobei nur die 4 besten Ergebnisse addiert und die schlechten gestrichen werden.
Hier das Script von Ralf RPP34:

• Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Challenge As Range
  Dim Anz&, j&, M&, Sp&
  If Target.Count > 1 Then Exit Sub
  With Me.Range("Tabelle1")
   Set Challenge = Range(.Columns(5), .Columns(.Columns.Count - 2))
  End With
  If Not Intersect(Target, Challenge) Is Nothing Then
   With Target
      Anz = WorksheetFunction.Count(Challenge.Rows(.Row - 3))
      If Anz > 4 Then
         With Challenge.Rows(.Row - 3)
            .Borders(xlDiagonalUp).LineStyle = xlNone
            .Borders(xlDiagonalDown).LineStyle = xlNone
         End With
         For j = 1 To Anz - 4
            M = WorksheetFunction.Small(Challenge.Rows(.Row - 3), j)
            Sp = WorksheetFunction.Match(M, Challenge.Rows(.Row - 3), 0)
            With Cells(.Row, 4 + Sp)
               .Borders(xlDiagonalUp).LineStyle = xlContinuous
               .Borders(xlDiagonalDown).LineStyle = xlContinuous
               .Borders(xlDiagonalDown).Color = -16776961
               .Borders(xlDiagonalDown).Weight = xlMedium
            End With
         Next j
      End If
   End With
  End If
  End Sub
  
  

Das Script hat leider noch zwei kleine Fehler.(Die Tabelle mit den beiden kleinen Schönheitsfehlern dazu hier im Anhang):

1. Beim Sortieren der Tabelle werden die Kreuze nicht an die neuen Positionen verschoben und
   
2. Die Sportler ohne Einzelergebnisse sollen zusammen auf den letzten Platz gesetzt werden.
   (In der Beispieldatei wäre es für die letzten 6 Teilnehmer Platz 26.)
   

Bitte, kann mir hier jemand aus der Patsche helfen?

Viele Grüße
Bernd

[schauan]

Hallo Bernd,

würde es auch reichen, die Zellen einzufärben statt der "Kreuze"? Die Farben werden nämlich mit sortiert.
Ansonsten müsste man nach dem Sortieren alle Zeilen prüfen und die Kreuze neu setzen.