Eigentlich sollte das ja leicht zu berechnen sein mit



(In Worten: Die Größe des kleinsten Teilchen (k) verhält sich zur Atomgröße (a) wie die gesuchte Größe (x) zur Größe des beobachtbaren Universums (u).)

Die Probleme fangen an wenn wir versuchen die Variablen einzusetzen:

  • a

Je nachdem über welches Atom wir sprechen sind es 32 pm (Heliumatom), 225 pm (Caesiumatom) oder irgendwas dazwischen (1pm = 10^-12 m)

  • k

Wir haben keine Ahnung wie groß die Quarks tatsächlich sind, bisher werden sie als punktförmig mit Ausdehnung 0 angenommen. Das beste das wir haben ist, dass sie kleiner als 10^-19 m sind, die experimentell ermittelte Obergrenze der Größe eines Elektrons.

  • u

Wir haben keine Ahnung welche Form des Universum hat, zur Vereinfachung gehen wir mal davon aus das unser beobachtetes Universum von der Erde aus gesehen eine Kugel ergibt. Da unsere Beobachtung auf Licht zurückgeht ist können wir nichts beobachten das älter als das Universum selbst ist, diese gedachte Kugel hat daher einen Radius von 13,8 Mrd Lichtjahren. (~1,3*10^26 m)

Unter all diesen Annahmen kommt die Entsprechung auf einen Radius kleiner al mindestens 5,8 * 10^16 m (fürs Caesiumatom) bzw 4,08 * 10^17 m (fürs Heliumatom) (zum Vergleich das entspricht ~195000 mal von der Erde zur Sonne und zurück)

...zur Antwort

Sie berechnen zwar beide die Differenz zweier Tage, Tage360() benutzt dabei allerdings für jeden Monat 30 Tage während Tage() die tatsächlichen Kalendertage verwendet.

Bspw vom 1.2.23 bis zum 1.3.23 würde Tage() 28 und Tage360() 30 (da es einen 29. und 30. Februar gibt.) ausgeben.

...zur Antwort

Die Folge die du suchst ist die 4.te Episode der Pokémon Specials "Pikachu -Die Rettung".

...zur Antwort

Ein Foto von der Erscheinung machen. Wahlweise hast du dann etwas zur Untermauerung deiner Geschichte (für einen erneuten Versuch bei der Polizei) oder weißt das es nicht wirklich ist (und kannst deine Fantasie dagegen einsetzen).

...zur Antwort

Hallo,

vorweg falls ich dich richtig verstehe ist deine Liste in dieser Art aufgebaut?

Dann kannst du als Formel in der BF dies verwenden:

  • =TEXTKETTE(WENN(INDIREKT(ADRESSE(ZELLE("Zeile");2)&":"&ADRESSE(ZELLE("Zeile");10);1)="";"o";"x"))=TEXTKETTE(WENN($B2:$J2="";"o";"x"))

Ein Bereich kann nicht direkt verglichen werden, man kann aber alle Werte im Bereich miteinander verketten und diese Verkettung miteinander vergleichen, dafür sind die beiden Textkette() in der Formel, die Wenn() sind nötig um Leerwerte zu füllen damit zwischen bspw. xooxoo und xoooox unterschieden werden kann.

Soweit ich weiß kann man ohne VBA zwar über Zelle() die aktive Zelle auslesen, hat aber keine entsprechende Möglichkeit für den gesamten markierten Bereich. In deinem Fall sollte das allerdings ausreichen, da dich ja alle zugehörigen Türen interessieren. Daher wird über Indirekt() der entsprechende Bereich in der aktiven Zeile generiert.

Excel rechnet bei einer Selektionsänderung nicht automatisch neu, daher muss manuell per F9 aktualisiert werden.

PS: Die Funktion Textkette() ist erst ab Excel 2016 verfügbar in älteren Versionen müsste man die gewünschten Zellen einzeln (wahlweise über Verketten() oder &) miteinander verketten, da beide nicht mit einer Bereichsangabe umgehen können.

...zur Antwort

Hallo,

dazu solltest du dies verwenden können nachdem du die Bereiche an deine Arbeitsmappe angepasst hast. Die Tabelle wird dabei fortlaufend durchgegangen um Start- und End-Datum eines Projektes zu finden. Sobald beide vorhanden sind wird die nächste Farbe (bzw wieder die erste nachdem alle vorbereiteten durch sind) ausgewählt, der Eintrag in den Kalender übernommen und anschließend in der Tabelle das nächste Projekt gesucht.

Sub Kalenderreset()
Dim Datum As Date
Dim Tag As Long, Jahr As Long, Wtag As Long
Dim Ber As Range, Zelle As Range
Dim Monat As String


With ActiveWorkbook.Sheets("Tabelle3")
    Set Ber = .Range("A1:AF13")
    Ber.UnMerge
    Jahr = Ber.Cells(1, 1)
    For Each Zelle In Ber
        If Zelle.Column - Ber.Column > 0 And Zelle.Row - Ber.Row > 0 Then
            'im Kalenderbereich
            Zelle.ClearContents
            Tag = Ber.Cells(1, Zelle.Column).Value
            Monat = Ber.Cells(Zelle.Row, 1)
            
            If IsDate(Tag & "." & Monat & "." & Jahr) Then
                Datum = DateValue(Tag & "." & Monat & "." & Jahr)
                Wtag = Application.WorksheetFunction.Weekday(Datum, 1)
                If Wtag > 5 Then
                    'Wochenende
                    Zelle.Interior.Color = RGB(127, 127, 127)
                Else
                    'kein Wochenende
                    Zelle.Interior.Pattern = xlNone
                End If
            Else
                'unmögliches Datum
                Zelle.Interior.Pattern = xlNone
            End If
        End If
    Next Zelle
    
End With
End Sub


Sub Kalendereintrage()


Dim Start As Boolean
Dim SDatum As Date, EDatum As Date
Dim Farbe(2) As Long, f As Long
Dim d As Long, z As Long
Dim KBer As Range, Zelle As Range, Tabelle As Range, TZelle As Range
Dim Szelle As Range, EZelle As Range, DZelle As Range, DDZelle As Range
Dim Nam As String
Dim Kalender As Worksheet


Dim Datum As Date
Dim Tag As Long, Jahr As Long, Wtag As Long
Dim Monat As String


'Bereiche etc festlegen
Set Kalender = ActiveWorkbook.Sheets("Tabelle3")
Set KBer = Kalender.Range("A1:AF13") 'Kalenderbereich + je 1 Zeile/Spalte Beschriftung
Set Tabelle = ActiveWorkbook.Sheets("Tabelle2").Range("D2:D16") 'Namenspalte der Tabelle ohne Überschrift + 1 weitere Leerzeile
Start = False


f = -1
Farbe(0) = RGB(255, 0, 0)
Farbe(1) = RGB(0, 255, 0)
Farbe(2) = RGB(0, 0, 255)


'Kalender resetten
KBer.UnMerge
Jahr = Year(Date) + 1


For Each Zelle In KBer
    If Zelle.Column - KBer.Column > 0 And Zelle.Row - KBer.Row > 0 Then
        'im Kalenderbereich
        Zelle.ClearContents
        Tag = KBer.Cells(1, Zelle.Column).Value
        Monat = KBer.Cells(Zelle.Row, 1)
            
        If IsDate(Tag & "." & Monat & "." & Jahr) Then
            Datum = DateValue(Tag & "." & Monat & "." & Jahr)
            Wtag = Application.WorksheetFunction.Weekday(Datum, 2)
            If Wtag > 5 Then
                'Wochenende
                Zelle.Interior.Color = RGB(127, 127, 127)
            Else
                'kein Wochenende
                Zelle.Interior.Pattern = xlNone
            End If
        Else
            'unmögliches Datum
            Zelle.Interior.Pattern = xlNone
        End If
    End If
Next Zelle




'Namensspalte durchgehen
For Each TZelle In Tabelle
    If TZelle.Value <> Nam Then
        If Nam = "" Then
            'erster Treffer
            Nam = TZelle.Value
            For Each Zelle In KBer
                If KBer.Cells(1, Zelle.Column) = Day(TZelle.Offset(0, -1).Value) And Month("1." & KBer.Cells(Zelle.Row, 1).Value) = Month(TZelle.Offset(0, -1).Value) Then
                    'Starttag
                    Set Szelle = Zelle.Offset(KBer.Row - 1, KBer.Column - 1)
                    Szelle.Value = Nam
                    SDatum = TZelle.Offset(0, -1).Value
                    Start = True
                    Exit For 'zelle Start
                End If
            Next Zelle
        ElseIf Nam <> "" And Start Then
            'Eintrag Ende
            For Each Zelle In KBer
                If KBer.Cells(1, Zelle.Column) = Day(TZelle.Offset(-1, -1).Value) And Month("1." & KBer.Cells(Zelle.Row, 1).Value) = Month(TZelle.Offset(-1, -1).Value) Then
                    'Endtag
                    Set EZelle = Zelle.Offset(KBer.Row - 1, KBer.Column - 1)
                    EDatum = TZelle.Offset(-1, -1).Value
                    f = (f + 1) Mod (UBound(Farbe) + 1)
                    Exit For 'zelle Ende
                End If
            Next Zelle
            If Szelle.Row = EZelle.Row Then
                'kein Monatsübergang im Projekt
                With Kalender.Range(Szelle, EZelle)
                    .Merge
                    .VerticalAlignment = xlCenter
                    .HorizontalAlignment = xlCenter
                    .Interior.Color = Farbe(f)
                End With
                'Kalender.Range(szellemezelle).Color = Farbe(f)
            Else
                'Monatsübergang im Projekt
                'Startdatum bis Monatende
                Set DZelle = Szelle.Offset(0, Day(DateValue("1." & Month(SDatum) + 1) - 1) - Day(SDatum))
                With Kalender.Range(Szelle, DZelle)
                    .Merge
                    .VerticalAlignment = xlCenter
                    .HorizontalAlignment = xlCenter
                    .Interior.Color = Farbe(f)
                End With
                
                'Zwischenmonate
                z = 0
                Do Until Month(EDatum) - Month(SDatum) - z = 1
                    Set DZelle = Szelle.Offset(z + 1, 0 - Day(SDatum) + 1)
                    Set DDZelle = DZelle.Offset(0, Day(DateValue("1." & Month(SDatum) + z + 1) - 1) - 1)
                    DZelle.Value = Nam
                    With Kalender.Range(DZelle, DDZelle)
                        .Merge
                        .VerticalAlignment = xlCenter
                        .HorizontalAlignment = xlCenter
                        .Interior.Color = Farbe(f)
                    End With


                    z = z + 1
                Loop
                
                'Rest im Endmonat
                Set DZelle = EZelle.Offset(0, 0 - Day(EDatum) + 1)
                DZelle.Value = Nam
                With Kalender.Range(EZelle, DZelle)
                    .Merge
                    .VerticalAlignment = xlCenter
                    .HorizontalAlignment = xlCenter
                    .Interior.Color = Farbe(f)
                End With
                
            End If
            Start = False
            Set Szelle = Nothing
            Set EZelle = Nothing
            Nam = ""
            If TZelle.Value <> "" Then
                'nächster Projekt beginnt direkt nach Abschluss des letzten
                Nam = TZelle.Value
                For Each Zelle In KBer
                    If KBer.Cells(1, Zelle.Column) = Day(TZelle.Offset(0, -1).Value) And Month("1." & KBer.Cells(Zelle.Row, 1).Value) = Month(TZelle.Offset(0, -1).Value) Then
                        'Starttag
                        Set Szelle = Zelle.Offset(KBer.Row - 1, KBer.Column - 1)
                        Szelle.Value = Nam
                        SDatum = TZelle.Offset(0, -1).Value
                        Start = True
                        Exit For 'zelle Start
                    End If
                Next Zelle
            End If
            
        End If
    End If
Next TZelle


End Sub
...zur Antwort

Es gibt primäre und sekundäre Statusveränderungen. Primäre Statusveränderungen werden per Symbol bei der KP-Leiste angezeigt und verhindern das sie eine andere primäre Statusveränderung erhalten (mit Ausnahme von Erholungsschlaf der sie überschreibt). Sekundäre Statusveränderungen können dagegen gleichzeitig mit anderen Statusveränderungen wirken. Sandsturm ist keine Statusveränderung sondern ein Wettereffekt.

...zur Antwort

Hallo,

mit Farben kann Excel von sich aus nicht gut umgehen. Falls du eine weitere Spalte hast in der Damen/Männer/Uni erkennbar ist, könnte man diese als Kriterium für drei bedingte Formatierung nehmen, falls nicht muss man VBA bemühen.

Den VBA-Editor kannst du über die Registerkarte "Entwicklertools" -> Makros (muss ggfls in den Optionen aktiviert werden) bzw Alt+F11 öffnen und diesen Code in das Modul des Tabellenblattes (Doppelklick auf den Namen in der Liste links) einfügen und die Bereiche entsprechend anpassen:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Ber As Range, zelle As Range


Set Ber = ActiveSheet.Range("A:A") 'Deine Tabelle, vorzugsweise derselbe Bereich aus dem das Dropdown kommt


If Target.Address(False, False) = "C1" Then 'Suchfeld
    If Target.Value = "" Or Application.WorksheetFunction.CountIf(Ber, Target.Value) = 0 Then 'bei Leerwert oder nicht vorhanden Farbe zurücksetzen
        Target.Interior.Pattern = xlNone
    Else
        For Each zelle In Ber
            If zelle.Value = Target.Value Then
                Application.EnableEvents = False 'Selbstauslöser verhindern
                Target.Interior.Color = zelle.Interior.Color 'setze Suchfeldfarbe gleich Farbe des Eintrags in der Tabelle
                Application.EnableEvents = True
                Exit For
            End If
        Next zelle
    End If
End If
End Sub
...zur Antwort

Eine Kürbismaske gab es in Vanilla nie. Man kann aber einen normalen Kürbis im Helmslot platzieren bis diese Funktion in Version 1.13 vom geschnitzten Kürbis übernommen wurde, falls du das meinst.

...zur Antwort

Zunächst wird mittels wb2.Sheets(1).Rows(i).Copy eine gesamte Zeile im ersten Blatt der als "wb2" festgelegten Arbeitsmappe kopiert. Der Codeschnipsel befindet sich vermutlich innerhalb einer For i=a to b Schleife um zeilenweise das gesammte Blatt durchzugehen.

Anschließend werden die Werte (.Pastespecial xlPasteValues) unter die letzte Zeile des als "ws" festgelegte Blattes eingefügt. ws.Cells(ws.Rows.Count, 1) ist die letzte benutzbare Zelle in Spalte A, End(xlUp) geht von unten nach oben alle Zeilen durch bis eine benutzte gefunden wird und es wird per .Offset(1) um eine Zeile verschoben.

Wie kann ich beim "Paste" etwas hinzufügen das beim "Copy" oben noch nicht da war?

Copy kopiert alles was vorhanden ist, was übernommen wird entscheidet die gewählte Paste-Option bspw. xlPasteAll für alles, xlPasteFormats für Formatierungen und xlPasteFormulas für Formeln.

...zur Antwort

Hallo,

Excel behandelt Datumswerte als normale Zahlen, du müsstest also eine Wenn()-Formel in der Art verwenden können:

  • =WENN(UND(A1>B1;A1<C1);"UT";"")
  • A=Prüfdatum, B = Anfangsdatum, C =Enddatum
...zur Antwort
brennt eine Lampe, die geht nur an oder aus

Ich nehme an es ist den Personen erlaubt die Lampe umzuschalten, niemand sonst rührt sie an und sie brennt ewig bis sie ausgeschaltet wird.

Dann kann man sich absprechen wie folgt zu handeln:

  • Lampe an -> nichts tun
  • Lampe aus, beim ersten Mal -> Lampe anschalten
  • Lampe aus, bei weiteren Malen -> nichts tun

Zusätzlich legt man eine Person fest die die Lampe bei jedem Besuch des Raumes ausschaltet und mitzählt wie oft sie sie ausgeschaltet hat. Sobald das 30mal getan ist waren alle drin.

...zur Antwort

Hallo,

ich bin nicht sicher ob ich richtig verstehe was du vorhast aber evtl hilft dir das Folgende trotzdem weiter :?

Da ich auf 3600 (((12^2-24)/2)^2) mögliche Matches komme schien mir eine zufällige Auswahl sinnvoll und da Zufallszahlen einfacher zu bearbeiten sind, wenn man unbrauchbare aussortieren kann die Verwendung von VBA.

Das erste Makro bereitet ein Tabellenblatt auf um Zwischenzuspeichern welche Spieler bereits zusammen, gegeneinander und wie oft gespielt haben, das zweite generiert die Spieler nacheinander. Spieler 1 wird dabei aus den Spielern mit den wenigsten Spielen gewählt und Spieler 2-4 nacheinander aus den noch möglichen Partnern/Gegnern:

Sub Setup()
Dim Ber As Range, Zelle As Range
Dim Spa As Long, Zei As Long, i As Long
With ActiveSheet
    Set Ber = .Range("A1:Z25")
    Zei = 1
    Spa = 1
    .Range("AA:AE").ClearContents
    .Range("AA1") = "Match"
    For i = 1 To 4
        .Range("AA1").Offset(0, i).Value = "Spieler " & i
    Next i
    
    For i = 1 To 24
        If i <= 12 Then
            Ber.Cells(1, i + 1).Value = "A" & Application.WorksheetFunction.Text(i, "00")
            Ber.Cells(i + 1, 1).Value = "A" & Application.WorksheetFunction.Text(i, "00")
        Else
            Ber.Cells(1, i + 1).Value = "P" & Application.WorksheetFunction.Text(i - 12, "00")
            Ber.Cells(i + 1, 1).Value = "P" & Application.WorksheetFunction.Text(i - 12, "00")
        End If
            Ber.Cells(1, 26).Value = "Anzahl Spiele"
            Ber.Cells(i + 1, 26).FormulaR1C1 = "=COUNTIF(C[2]:C[5],RC[-25])"
    Next i
    
    For Each Zelle In Ber
        If (Zelle.Row > Ber.Row And Zelle.Column > Ber.Column And Zelle.Column < 26) Then
            If Ber.Cells(Ber.Row, Zelle.Column).Value = Ber.Cells(Zelle.Row, Ber.Column).Value Then
                Zelle.Value = "nein"
            Else
                Zelle.Value = "ja"
            End If
        End If
    Next Zelle
    .Columns("A:Z").EntireColumn.AutoFit
End With


End Sub


Sub Auswahl()
Dim gultPart As Boolean, gultGeg As Boolean, nVersuch As Boolean
Dim i As Long, dCo As Long
Dim lZei As Long, Zufall As Long, Spa As Long, Zei As Long
Dim S1 As String, S2 As String, S3 As String, S4 As String, S5 As String
Dim Status As String, A As String, B As String
Dim SpielZahl As Range, Zelle As Range, Partnerwahl As Range, GPV As Range, GPVS As Range, GPVZ As Range
Dim GPVZU As Range


Dim Anz As Long, Zahler As Long, inf As Long, infCO As Long, CancWdh As Long, CancWdhCO As Long
infCO = 99999 'Anzahl Schleifendurchläfe nach denen automatisch abgebrochen wird
CancWdhCO = 99 'Anzahl versuchter wiederholungen
Anz = 6 ' festlegen wieviele generiert werden sollen




Dim ja As String, nein As String, Partner As String, Gegner As String
ja = "ja"
nein = "nein"
Partner = "P"
Gegner = "G"


Zahler = 0
inf = 0
CancWdh = 0


Set SpielZahl = ActiveSheet.Range("Z1:Z25")
Set GPV = ActiveSheet.Range("A1:Y25")
Set GPVS = ActiveSheet.Range("A1:A25")
Set GPVZ = ActiveSheet.Range("A1:Y1")


Do Until Zahler = Anz
nVersuch = False
Zahler = Zahler + 1
    
    inf = inf + 1
    If inf >= infCO Then
        MsgBox "Unendliche Schleife vermutet, abgebrochen."
        End
    End If


With Application.WorksheetFunction
'Spieler 1 Festlegen aus den Personen mit der wenigsten Anzahl vergebener Spieler
    Randomize
    Zufall = Int((.CountIf(SpielZahl, .Min(SpielZahl))) * Rnd + 1)
    dCo = 0
    For Each Zelle In SpielZahl
        If Zelle.Value = .Min(SpielZahl) Then
            dCo = dCo + 1
            If dCo = Zufall Then
                S1 = ActiveSheet.Range("A" & Zelle.Row)
                Exit For
            End If
        End If
    Next Zelle
'Spieler 2 festlegen
    S2 = S1
    If Left(S1, 1) = "P" Then
        Set Partnerwahl = ActiveSheet.Range("A1:A13")
    Else
        Set Partnerwahl = ActiveSheet.Range("A14:A25")
    End If
    
    Spa = .Match(S1, ActiveSheet.Range("A1:Y1"), 0)
    If Left(S1, 1) = "A" Then
        Set GPVZU = ActiveSheet.Range(ActiveSheet.Cells(14, Spa), ActiveSheet.Cells(25, Spa))
    Else
        Set GPVZU = ActiveSheet.Range(ActiveSheet.Cells(2, Spa), ActiveSheet.Cells(13, Spa))
    End If
        
    gultPart = False
    
    Do Until gultPart
        inf = inf + 1
        If inf >= infCO Then
            MsgBox "Unendliche Schleife vermutet, abgebrochen."
            End
        End If
    
        If .CountIf(GPVZU, ja) + .CountIf(GPVZU, Partner) = 0 Then
            'MsgBox "Kein gültiger Partner für Spieler " & S1 & " möglich."
            CancWdh = CancWdh + 1
            nVersuch = True
            'End
            GoTo neuVersuch
        End If
        Randomize
        Zufall = Int((.CountIf(GPVZU, ja) + .CountIf(GPVZU, Partner)) * Rnd + 1)
        dCo = 0
        For Each Zelle In GPVZU
            If Zelle.Value = ja Or Zelle.Value = Partner Then
                dCo = dCo + 1
                If dCo = Zufall Then
                    S2 = ActiveSheet.Range("A" & Zelle.Row)
                    gultPart = True
                    Exit For
                End If
            End If
        Next Zelle
    Loop
    
'Spieler 3 festlegen
    S3 = S1
    gultGeg = False
    Do Until gultGeg
        inf = inf + 1
        If inf >= infCO Then
            MsgBox "Unendliche Schleife vermutet, abgebrochen."
            End
        End If
        
        dCo = 0
        For Each Zelle In GPVS 'Anzahl gültiger Gegner bestimmen
            'gültiger Gegner S1
            If Zelle.Offset(0, .Match(S1, GPVZ, 0) - 1).Value = ja Or Zelle.Offset(0, .Match(S1, GPVZ, 0) - 1).Value = Gegner Then
                'gültiger Gegner S2
                If Zelle.Offset(0, .Match(S2, GPVZ, 0) - 1).Value = ja Or Zelle.Offset(0, .Match(S2, GPVZ, 0) - 1).Value = Gegner Then
                    dCo = dCo + 1
                End If
            End If
        Next Zelle
        
        If dCo = 0 Then
            'MsgBox "Kein gültiger Gegner für das Spielerpaar " & S1 & "+" & S2 & " möglich."
            CancWdh = CancWdh + 1
            nVersuch = True
            'End
            GoTo neuVersuch
        End If
        
        Randomize
        Zufall = Int((dCo) * Rnd + 1)
        dCo = 0
        
        For Each Zelle In GPVS 'Gegner bestimmen
            'gültiger Gegner S1
            If Zelle.Offset(0, .Match(S1, GPVZ, 0) - 1).Value = ja Or Zelle.Offset(0, .Match(S1, GPVZ, 0) - 1).Value = Gegner Then
                'gültiger Gegner S2
                If Zelle.Offset(0, .Match(S2, GPVZ, 0) - 1).Value = ja Or Zelle.Offset(0, .Match(S2, GPVZ, 0) - 1).Value = Gegner Then
                    dCo = dCo + 1
                    If dCo = Zufall Then
                        S3 = Zelle.Value
                        gultGeg = True
                        Exit For 'zelle
                    End If
                End If
            End If
        Next Zelle
    Loop
    
'Spieler 4 festlegen
    S4 = S1
    gultGeg = False
    gultPart = False
    If Left(S3, 1) = "P" Then
        Set Partnerwahl = ActiveSheet.Range("A1:A13")
    Else
        Set Partnerwahl = ActiveSheet.Range("A14:A25")
    End If
    
    Do Until gultGeg And gultPart
        inf = inf + 1
        If inf >= infCO Then
            MsgBox "Unendliche Schleife vermutet, abgebrochen."
            End
        End If
        
        dCo = 0
        For Each Zelle In Partnerwahl 'Anzahl gültiger Gegner & Partner bestimmen
            'gültiger Gegner S1
            If Zelle.Offset(0, .Match(S1, GPVZ, 0) - 1).Value = ja Or Zelle.Offset(0, .Match(S1, GPVZ, 0) - 1).Value = Gegner Then
                'gültiger Gegner S2
                If Zelle.Offset(0, .Match(S2, GPVZ, 0) - 1).Value = ja Or Zelle.Offset(0, .Match(S2, GPVZ, 0) - 1).Value = Gegner Then
                    'gültiger Partner S3
                    If Zelle.Offset(0, .Match(S3, GPVZ, 0) - 1).Value = ja Or Zelle.Offset(0, .Match(S3, GPVZ, 0) - 1).Value = Partner Then
                        dCo = dCo + 1
                    End If
                End If
            End If
        Next Zelle
        
        If dCo = 0 Then
            'MsgBox "Kein gültiger Partner für " & S3 & " gegen das Spielerpaar " & S1 & "+" & S2 & " möglich."
            CancWdh = CancWdh + 1
            nVersuch = True
            'End
            GoTo neuVersuch
        End If
        
        Randomize
        Zufall = Int((dCo) * Rnd + 1)
        dCo = 0
        
        For Each Zelle In Partnerwahl 'letzten gültiger Gegner & Partner bestimmen
            'gültiger Gegner S1
            If Zelle.Offset(0, .Match(S1, GPVZ, 0) - 1).Value = ja Or Zelle.Offset(0, .Match(S1, GPVZ, 0) - 1).Value = Gegner Then
                'gültiger Gegner S2
                If Zelle.Offset(0, .Match(S2, GPVZ, 0) - 1).Value = ja Or Zelle.Offset(0, .Match(S2, GPVZ, 0) - 1).Value = Gegner Then
                    'gültiger Partner S3
                    If Zelle.Offset(0, .Match(S3, GPVZ, 0) - 1).Value = ja Or Zelle.Offset(0, .Match(S3, GPVZ, 0) - 1).Value = Partner Then
                        dCo = dCo + 1
                        If dCo = Zufall Then
                            S4 = Zelle.Value
                            gultGeg = True
                            gultPart = True
                            Exit For 'zelle
                        End If
                    End If
                End If
            End If
        Next Zelle
    Loop
End With '.Worksheetfunction
    
'sortieren zu A+P vs A+P
If Left(S1, 1) = "P" Then
    S5 = S1
    S1 = S2
    S2 = S5
End If


If Left(S3, 1) = "P" Then
    S5 = S3
    S3 = S4
    S4 = S5
End If


    'MsgBox S1 & Chr(10) & S2 & Chr(10) & S3 & Chr(10) & S4
    'MsgBox S1 & "+" & S2 & " vs " & S3 & "+" & S4


With ActiveSheet
'Match & Spieler auflisten
    lZei = .Range("AA" & .Rows.Count).End(xlUp).Row + 1
    .Range("AA" & lZei) = S1 & "+" & S2 & " vs " & S3 & "+" & S4
    .Range("AB" & lZei) = S1
    .Range("AC" & lZei) = S2
    .Range("AD" & lZei) = S3
    .Range("AE" & lZei) = S4
End With


'GPV aktualisieren
    dCo = 0
    For Each Zelle In GPV
        A = Application.WorksheetFunction.Index(GPV, 1, Zelle.Column)
        B = Application.WorksheetFunction.Index(GPV, Zelle.Row - GPV.Row + 1, 1)
        Status = Zelle.Value
        
        'spielen zusammen
        If (A = S1 And B = S2) Or (A = S2 And B = S1) Or (A = S3 And B = S4) Or (A = S4 And B = S3) Then
            If Status = Partner Then 'Partner -> hatten bereits gegeneinander gespielt -> keine weitere Interaktion der beiden
                Zelle.Value = nein
            Else
                Zelle.Value = Gegner
            End If
        End If
        
        'sind Gegner
        If (A = S1 And B = S3) Or (A = S1 And B = S4) Or (A = S2 And B = S3) Or (A = S2 And B = S4) _
            Or (B = S1 And A = S3) Or (B = S1 And A = S4) Or (B = S2 And A = S3) Or (B = S2 And A = S4) Then
            If Status = Gegner Then 'Gegner -> hatten bereits miteinander gespielt -> keine weitere Interaktion der beiden
                Zelle.Value = nein
            Else
                Zelle.Value = Partner
            End If
        End If
    Next Zelle
neuVersuch:
If nVersuch Then
    Zahler = Zahler - 1
End If


If CancWdh = CancWdhCO Then
    MsgBox "Abgebrochen nachdem " & CancWdhCO & " mal kein neuer Eintrag gefunden wurde."
    End
End If
Loop


End Sub
...zur Antwort

Hallo,

dazu kannst du dies verwenden:

Sub Tabellentext_zusammenfassen()
Dim i As Long, lZei As Long
Dim CopBer As Range, Zelle As Range
Dim AusBer As String, AusBlatt As String


    For i = 1 To 12
'Bereiche und Blatt festlegen das ausgelesen wird
        AusBlatt = "Tabelle" & i
        Select Case i
            
        Case 1
            AusBer = "A45:A47"
        Case 2
            AusBer = "A35:A37, A68:A80, A105:A117, A141:A155, A178:A196"
        Case 3 'gilt für 3-7 da die Fälle 4-7 nicht anders festgelegt sind
            AusBer = "A40:A45, A85:A90, A130:A135, A175:A180"
        Case 8
            AusBer = "A42:A44"
        Case 9
            AusBer = "A44:A48"
        Case 10
            AusBer = "A37:A40"
        Case 11
            AusBer = "A27:A48"
        Case 12
            AusBer = "A27:A31"
        End Select
        
        Set CopBer = ActiveWorkbook.Sheets(AusBlatt).Range(AusBer)
        
'Inhalte kopieren unter Ausschluss von Leerwerten
        With ActiveWorkbook.Sheets("Tabelle13")
            For Each Zelle In CopBer
                If Zelle.Value <> "" Then
                    lZei = Application.WorksheetFunction.Max(95, .Range("A" & .Rows.Count).End(xlUp).Row + 1)
                    .Range("A" & lZei) = Zelle.Value
                End If
            Next Zelle
        End With
    Next i
End Sub

Es wird jedes Blatt durchgegangen, darauf der gewünschte Bereich festgelegt und Zelle für Zelle aufgelistet. Sollten deine Blätter nicht tatsächlich Tabelle1 , Tabelle2 etc. heißen müsstest du den Blattnamen noch mit in den Fällen anpassen.

...zur Antwort

Hallo,

wäre es für euch eine Option das Design direkt in Excel zu bauen? (Vorzugsweise in einer eigenen Arbeitsmappe) Über Datei-> Exportieren -> "PDF/XPS Dokument erstellen" lässt sich eine Exceldatei als PDF speichern.

...zur Antwort

Es ist möglich mit einem Makro dieser Art:

Sub a()
Dim inf As Long
    Do Until ActiveSheet.Range("A1").Value = 0
        Calculate
        inf = inf + 1
        If inf > 10000 Then
            MsgBox "unendliche Schleife vermutet, der Vorgang wird abgebrochen"
            End
        End If
    Loop
End Sub


Aber was genau probierst du aus das du so etwas brauchst :?

...zur Antwort

Hallo,

Excel behandelt die Zellfarbe und eine per bedingter Formatierung festgelegte Farbe separat. Das kann man ausnutzen indem man die Farbe nach Bedarf über die BF ausblendet ohne das die Farbe tatsächlich verloren geht. Leider stellt Excel von sich aus keine Funktion um die Hintergrundfarbe einer Zelle auszulesen zur Verfügung, daher muss man auf VBA zurückgreifen um sie selbst zu erstellen:

Public Function HGFarbe(ByVal Target As Range)
    HGFarbe = Target.Interior.Color
End Function

Zusätzlich braucht es noch zwei Hilfsspalten, eine in der die Farbnummern aufgelistet werden und die andere um sie umzuschalten.

  • Hilfsspalte A : ja/nein je nachdem was ausgeblendet werden soll
  • Hilfsspalte B: =WENN(A1="ja";hgfarbe(B1);"") ,und die Zellen in den verwendeten Farben markieren
  • Bedingte Formatierung: =ISTFEHLER(VERGLEICH(hgfarbe(C1);$B:$B;0)) und unter Ausfüllen "keine Farbe" wählen
...zur Antwort

Hi,

für dein Vorhaben scheint eine Verweisfunktion besser geeignet zu sein als eine Wenn(), da du die zusammengehörenden Einträge vermutlich nicht immer in derselben Zeile haben wirst. Z.B kannst du dafür Index() und Vergleich() oder in neueren Versionen XVerweis() benutzen:

  • =INDEX(D:D;VERGLEICH(A1;C:C;0))
  • =XVERWEIS(A1;C:C;D:D;"Nummer nicht gefunden")

Vergleich() sucht den Wert aus A1 in Spalte C und gibt die Zeilennummer aus die Index() in den entsprechenden Eintrag in Spalte D übersetzt., XVerweis() funkioniert nach demselben Prinzip, die Funktion ist aber erst nach Excel 2019 benutzbar.

...zur Antwort