Makroerweiterung

[knallebumm]

Hallo,
nachdem ich jetzt ein paarmal, äußerst erfolglos, versucht habe mein Makro umzuschreiben, bitte ich euch um Hilfe.
Dies Makro (hier das Modul 2) hat mir vor einiger Zeit jemand auf Online Exel geschrieben.
Leider habe ich den Namen vergessen und da Online Exel im Moment Offline ist kann ich auch nicht nachschauen.
Dies ist eine Einteilungstabelle für Schiedsrichter.
Die Auswahl der Schiedsrichter die mir in den einzelnen Ligen in den Spalten Umpire1 und Umpire 2 angezeigt werden ist abhängig davon ob der Schiedsrichter an dem Datum schon eingeteilt ist und ob der Verein Spielt dem der Schiedsrichter angehört.
Ich möchte die Auswahl jetzt erweitern, darauf ob der Schiedsrichter an dem Tag auch Zeit hat.
Dafür habe ich jetzt auf dem Blatt Schiedsrichter in den Spalten E bis BN eine Datumstabelle erstellt, in der ich einfach ein Kreuz mache wenn der Schiedsrichter keine Zeit (also nicht eingeteilt werden kann) hat.
Jetzt soll das Makro diese Tabelle zusätzlich durchsuchen ob an dem betreffenden Datum bei dem Schiedsrichter ein Kreuz ist, wenn ja dann darf er nicht in der Auswahl erscheinen.
Die Hilfsspalten die das Makro benötigt kann in BQ angelegt werden ( jetzt in L ).
Ich hoffe ich hab es einigermaßen verständlich gemach und dies ist irgendwie Lösbar.

Danke und Gruß
Thomas


  Einteilungsvorlage vorlage für Forum.xlsm (Größe: 151,92 KB / Downloads: 23)

[knallebumm]

HAllo,
habe ich zuwenig Infos gegeben?
Dies ist kein Crossposting !
Diese Frage / Bitte habe ich nur hier gestellt.
Wenn ich irgendwie was falsch gemacht habe, so wäre eine kurze Info doch schön.

Gruß
Thomas

[Rabe]

Hallo Thomas,

Wenn ich irgendwie was falsch gemacht habe, so wäre eine kurze Info doch schön.

nee, Du hast nichts falsch gemacht, vielleicht haben alle keine Zeit oder auch keine Idee, wie das Problem lösbar ist.

[atilla]

Hallo Thomas,

hab da mal versucht etwas zusammen zu friemeln.

Teste mal ob es das ist, was Du wolltest:

Code:

Option Explicit
Public Ta, Tr

Sub Schiedsrichter_auswählen()

Dim liste() As String, liste2() As String, w, ce, i, z, k, m, x, y, n
Dim isec, isec2, V1, V2, Tag1, Tag2, Person, na
Dim myRange As Range, myRange1 As Range, myRange2 As Range, feld

  'Bereich in dem Schiedsrichter eingetragen werden. anpassen!
Set myRange = Range("G3:H150")

  ' Namen aller Schiedsrichter
Set myRange1 = Worksheets("Schiedsrichter").Range("A1:A151")
feld = Worksheets("Schiedsrichter").Range("A1:BN151")
  'Vereinszugehörigkeit aller Schiedsrichter
Set myRange2 = Worksheets("Schiedsrichter").Range("C1:C151")

Set isec = Intersect(Range(Ta), myRange)

  'Infos aus aktueller Zeile
If Not isec Is Nothing Then
  Worksheets("Schiedsrichter").Range("BQ:BQ").Clear
  V1 = Cells(Tr, 5)
  V2 = Cells(Tr, 6)
  Tag1 = Cells(Tr, 2)

  ' Anzahl aller Schiedsrichter
x = Worksheets("Schiedsrichter").Cells(Rows.Count, 1).End(xlUp).Row
ReDim liste(2, 200)
ReDim liste2(1 To x)

  'alle Schiedsrichter in Liste(1,) eintragen
i = 1
   For Each ce In myRange1
      n = n + 1
        y = Application.Match(CDbl(Tag1), Worksheets("Schiedsrichter").Range("A2:BN2"), 0)
      If IsNumeric(y) Then
         If feld(n, y) = "" Then
            liste(1, i) = ce.Value
            i = i + 1
         End If
      End If
   Next ce
  
  'am gleichen Tag eingesetzte Schiedsrichter in Liste(2,) eintragen
  z = 1
   For Each w In Worksheets
     Select Case w.Index
     Case 1 To 8
        For Each ce In w.Range("G3:H150")  'anpassen
           If ce.Value <> "" Then
              Person = ce.Value
              Tag2 = w.Cells(ce.Row, 2)
                If Tag1 = Tag2 Then
                liste(2, z) = Person
                 z = z + 1
               End If
           End If
        Next ce
     End Select
   Next w
    
  'Vereinzugehörigkeit prüfen und ggfs an Liste(2,) anhängen
  For Each ce In myRange2
        If ce = V1 Or ce = V2 Then
           Person = ce.Offset(0, -2)
           liste(2, z) = Person
           z = z + 1
        End If
     Next ce
                
  'alle Personen aus liste(2,) in Liste(1) löschen
  For i = 1 To x
    z = 0
     For k = 1 To 150
       If liste(1, i) = liste(2, k) Then z = 1
      Next k
     If z = 1 Then liste(1, i) = ""
    Next i
    
  'Liste(1) nach Liste2 übertragen, leere Felder ignorieren
  z = 1
   For i = 1 To x
     If liste(1, i) <> "" Then
        liste2(z) = liste(1, i)
        z = z + 1
     End If
   Next i
  
  'Hilfsspalte anlegen
For k = 1 To x
   Worksheets("Schiedsrichter").Cells(k, 69) = liste2(k)
Next

  'Bereich festlegen und Namen vergeben
x = Worksheets("Schiedsrichter").Cells(Rows.Count, 69).End(xlUp).Row
na = "=" & "Schiedsrichter!Z1S69:Z" & x & "S69"
ActiveWorkbook.Names.Add Name:="Namen", RefersToR1C1Local:=na

'Gültigkeit für aktive Zelle erstellen
For Each ce In Selection
   Set isec2 = Intersect(Range(ce.Address), myRange)
   If Not isec2 Is Nothing Then
      With ce.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=Namen"
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
       End With
    End If
Next ce
End If

End Sub

[knallebumm]

Hallo Atilla,
anscheinend funktioniert es nicht nur genauso wie ich mir das vorgestellt hatte sondern es macht auch mehr als es sollte.
Wenn kein Datum ( oder ein falsches Datum ) in den Ligen eingetragen ist, kann ich auch keine Schiedsrichter einteilen.
Das ist ein perfekter Nebeneffekt, den ich vorher nicht bedacht hatte.


Vielen Dank dafür.

Ich wollte durch meine Nachfrage aber auf keinen Fall irgenwenn nötigen sich meiner anzunehmen.
Wenn es nicht geht oder zu kompliziert ist, habe ich als erster dafür Verständnis ( Eine Info wäre nur Nett)

Ich hatte es zwischenzeitlich schon durch einfügen einer weiteren " Liga" ( die Ich Freimeldungen genannt habe ) gelöst.
Aber so ist es es übersichtlicher und einfacher zum eintragen.
Ich denke auch es wird der rauen Wirklichkeit der Einteilung, die im März beginnt, standhalten.
Die Probeläufe liefen auf jeden Fall ohne Probleme

Beste Grüße
Thomas

[knallebumm]

Hallo,
nachdem jetzt der Praxistest gelaufen ist, habe ich noch die Frage ob es möglich ist, das der Code auf jedem Tabellenblatt nur bis zur jeweils letzten beschriebenen Zeile sucht?
Es dauert doch ziemlich lange bis ich alle Namen angezeigt bekomme die zur Verfügung stehen.

Ich habe schon mal gelesen, dass es dafür auch einen Code gibt, aber ich wüsste nicht wo ich das einfügen müsste und wie ich den Code abändern muß.
Ich musste dann auf ein Drop Down Feld umsteigen und die Freimeldungen händisch abgleichen.
Hat zwar auch funktioniert , war aber etwas nervend und ist etwas fehlerbehaftet.

Code:

Option Explicit
Public Ta, Tr

Sub Schiedsrichter_auswählen()

Dim liste() As String, liste2() As String, w, ce, i, z, k, m, x, y, n
Dim isec, isec2, V1, V2, Tag1, Tag2, Person, na
Dim myRange As Range, myRange1 As Range, myRange2 As Range, feld

 'Bereich in dem Schiedsrichter eingetragen werden. anpassen!
Set myRange = Range("G3:H80") 'anpassen wenn die Spieltage über Zeile 80 hinausgehen

 ' Namen aller Schiedsrichter
Set myRange1 = Worksheets("Schiedsrichter").Range("A1:A130") 'anpassen wen Anzahl Umpire über 130 hinnausgeht
feld = Worksheets("Schiedsrichter").Range("A1:BN130") 'anpassen wen Anzahl Umpire über 130 hinnausgeht FREIMELDUNGEN
 'Vereinszugehörigkeit aller Schiedsrichter
Set myRange2 = Worksheets("Schiedsrichter").Range("C1:C130") 'anpassen wen Anzahl Umpire über 130 hinnausgeht VEREIN

Set isec = Intersect(Range(Ta), myRange)

 'Infos aus aktueller Zeile
If Not isec Is Nothing Then
 Worksheets("Schiedsrichter").Range("BQ:BQ").Clear
 V1 = Cells(Tr, 5)
 V2 = Cells(Tr, 6)
 Tag1 = Cells(Tr, 2)

 ' Anzahl aller Schiedsrichter
x = Worksheets("Schiedsrichter").Cells(Rows.Count, 1).End(xlUp).Row
ReDim liste(2, 200)
ReDim liste2(1 To x)

 'alle Schiedsrichter in Liste(1,) eintragen
i = 1
  For Each ce In myRange1
     n = n + 1
       y = Application.Match(CDbl(Tag1), Worksheets("Schiedsrichter").Range("A2:BN2"), 0)
     If IsNumeric(y) Then
        If feld(n, y) = "" Then
           liste(1, i) = ce.Value
           i = i + 1
        End If
     End If
  Next ce
 
 'am gleichen Tag eingesetzte Schiedsrichter in Liste(2,) eintragen
 z = 1
  For Each w In Worksheets
    Select Case w.Index
    Case 1 To 8
       For Each ce In w.Range("G3:H80")  'anpassen wenn die Spieltage über Zeile 80 hinausgehen
          If ce.Value <> "" Then
             Person = ce.Value
             Tag2 = w.Cells(ce.Row, 2)
               If Tag1 = Tag2 Then
               liste(2, z) = Person
                z = z + 1
              End If
          End If
       Next ce
    End Select
  Next w
   
 'Vereinzugehörigkeit prüfen und ggfs an Liste(2,) anhängen
 For Each ce In myRange2
       If ce = V1 Or ce = V2 Then
          Person = ce.Offset(0, -2)
          liste(2, z) = Person
          z = z + 1
       End If
    Next ce
               
 'alle Personen aus liste(2,) in Liste(1) löschen
 For i = 1 To x
   z = 0
    For k = 1 To 150
      If liste(1, i) = liste(2, k) Then z = 1
     Next k
    If z = 1 Then liste(1, i) = ""
   Next i
   
 'Liste(1) nach Liste2 übertragen, leere Felder ignorieren
 z = 1
  For i = 1 To x
    If liste(1, i) <> "" Then
       liste2(z) = liste(1, i)
       z = z + 1
    End If
  Next i
 
 'Hilfsspalte anlegen
For k = 1 To x
  Worksheets("Schiedsrichter").Cells(k, 69) = liste2(k)
Next

 'Bereich festlegen und Namen vergeben
x = Worksheets("Schiedsrichter").Cells(Rows.Count, 69).End(xlUp).Row
na = "=" & "Schiedsrichter!Z1S69:Z" & x & "S69"
ActiveWorkbook.Names.Add Name:="Namen", RefersToR1C1Local:=na

'Gültigkeit für aktive Zelle erstellen
For Each ce In Selection
  Set isec2 = Intersect(Range(ce.Address), myRange)
  If Not isec2 Is Nothing Then
     With ce.Validation
       .Delete
       .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
       xlBetween, Formula1:="=Namen"
       .IgnoreBlank = True
       .InCellDropdown = True
       .ShowInput = True
       .ShowError = True
      End With
   End If
Next ce
End If

End Sub

[atilla]

Hallo Thomas,

änder diesen Teil:

Code:

 For Each w In Worksheets
   Select Case w.Index
   Case 1 To 8
      For Each ce In w.Range("G3:H80")  'anpassen wenn die Spieltage über Zeile 80 hinausgehen
         If ce.Value <> "" Then
            Person = ce.Value
            Tag2 = w.Cells(ce.Row, 2)
              If Tag1 = Tag2 Then
              liste(2, z) = Person
               z = z + 1
             End If
         End If
      Next ce
   End Select
 Next w

so um:

  For Each w In Worksheets

    Select Case w.Index
    Case 1 To 8
        i = Application.Max(3, w.Cells(w.Rows.Count, 2).End(xlUp).Row) 'Letzte belegte Zelle in Spalte B (Datumsspalte) 
       For Each ce In w.Range("G3:H" & i)  'anpassen wenn die Spieltage über Zeile 80 hinausgehen
          If ce.Value <> "" Then
             Person = ce.Value
             Tag2 = w.Cells(ce.Row, 2)
               If Tag1 = Tag2 Then
               liste(2, z) = Person
                z = z + 1
              End If
          End If
       Next ce
    End Select
  Next w

[knallebumm]

Hallo Attila,
vielen Dank dafür.

Im Praxistest hat sich auch herrausgestellt, das die Vereinszugehörigkeit nur auf dem Tabellenblatt überprüft wird wo ich gerade die Schiedsrichter eingeben will.
Dies ist ein bischen suboptimal, da ich keine Schiedsrichter einteilen möchte, wenn dessen Verein am selben Datum in einer anderen Liga spielt.

Das konnte ich auch erst jetzt testen nachdem ich den Speilplan erhalten habe.
Gäbe es da noch einen zusatz der das leisten würde und alle Liga blätter durchsucht nach den o.g. Kriterien?


Gruß
Thomas

[atilla]

Hallo Thomas,

leider fehlt mir die Zeit mich da intensiver reinzuarbeiten bzw. reinzudenken.

Vielleicht kann ein anderer Forumsteilnehmer Dir weiterhelfen.

[knallebumm]

Hallo Attila,
danke für die Info.

Ich hab es jetzt händisch erledigt.

Ich probier es noch mal bei exel - online wo ich ja den Ursprungscode bekommen habe.
Es ist ja wieder online.

Wenn das nicht klappt komme ich wieder.

Gruß
Thomas