Registriert seit: 05.10.2014
Version(en): 2013 Pro plus
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)
Beste Grüße
Thomas
Registriert seit: 05.10.2014
Version(en): 2013 Pro plus
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
Beste Grüße
Thomas
Registriert seit: 10.04.2014
Version(en): 2016 + 365
Hallo Thomas,
(28.01.2015, 20:21)knallebumm schrieb: 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.
Folgende(r) 1 Nutzer sagt Danke an Rabe für diesen Beitrag:1 Nutzer sagt Danke an Rabe für diesen Beitrag 28
• knallebumm
Registriert seit: 14.04.2014
Version(en): 2003, 2007
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
Gruß Atilla
Folgende(r) 1 Nutzer sagt Danke an atilla für diesen Beitrag:1 Nutzer sagt Danke an atilla für diesen Beitrag 28
• knallebumm
Registriert seit: 05.10.2014
Version(en): 2013 Pro plus
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
Beste Grüße
Thomas
Registriert seit: 05.10.2014
Version(en): 2013 Pro plus
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
Beste Grüße
Thomas
Registriert seit: 14.04.2014
Version(en): 2003, 2007
29.03.2015, 13:14
(Dieser Beitrag wurde zuletzt bearbeitet: 29.03.2015, 13:27 von 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:
Zitat: 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
Gruß Atilla
Registriert seit: 05.10.2014
Version(en): 2013 Pro plus
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
Beste Grüße
Thomas
Registriert seit: 14.04.2014
Version(en): 2003, 2007
Hallo Thomas,
leider fehlt mir die Zeit mich da intensiver reinzuarbeiten bzw. reinzudenken.
Vielleicht kann ein anderer Forumsteilnehmer Dir weiterhelfen.
Gruß Atilla
Registriert seit: 05.10.2014
Version(en): 2013 Pro plus
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
Beste Grüße
Thomas
|