Excel automatisch Wahrheitstabellen anlegen | VBA for Beginner

Sub Wahrheitstabelle()
    Dim AnzahlSpalten As Integer
    Dim i As Long, j As Long, k As Long
    Dim letzteZeile As Long
    Dim ws As Worksheet

    ' Aktuelles Arbeitsblatt
    Set ws = ActiveSheet

    ' Anzahl der Werte - stehen im Bsp. in P1
    AnzahlSpalten = ws.Range("P1").Value
    
    ' Alle Zellen im aktiven Arbeitsblatt löschen
    ws.Cells.ClearContents
    ws.Cells.FormatConditions.Delete
    ws.Cells.Interior.ColorIndex = xlNone
    ws.Cells.Borders.LineStyle = xlNone

    ' Anzahl der Zeilen berechnen (2 hoch AnzahlSpalten; Bei 3 Werte wären es 2 hoch 3  = 2*2*2 = 8 Zeilen)
    letzteZeile = 2 ^ AnzahlSpalten

    ' Überschriften in der ersten zeile für die Spalten erstellen
    For i = 1 To AnzahlSpalten
        ws.Cells(1, i) = "Wert_" & i
    Next i
    With ws.Range(ws.Cells(1, 1), ws.Cells(1, AnzahlSpalten))
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .Borders(xlBottom).LineStyle = xlContinuous
    End With

    ' Wahrheitstabelle füllen
        'Angenommen, wir sind in der zweiten Zeile (also i = 2) und der dritten Spalte (j = 3).
        'Dann ist k = 1 und 2 ^ (j - 1) = 4. In binärer Darstellung ist 1 = 001 und 4 = 100.
        'Da an keiner Stelle beide Zahlen eine 1 haben, ist das Ergebnis 0 = False.
        'am Ende prüfen wir noch ob das Ergebnis ungleich 0 ist.
    For i = 2 To letzteZeile + 1
        k = i - 1
        For j = 1 To AnzahlSpalten
            ws.Cells(i, j) = (k And 2 ^ (j - 1)) <> 0
             ' Bedingte Formatierung basierend auf dem Wert
            If ws.Cells(i, j).Value Then
                ws.Cells(i, j).Interior.Color = RGB(200, 255, 200) ' Hellgrün
            Else
                ws.Cells(i, j).Interior.Color = RGB(255, 200, 200) ' Hellrot
            End If
            
            ' Rahmen für die erste und letzte Spalte jeder Zeile
            If j = 1 Then
                ws.Cells(i, j).Borders(xlEdgeLeft).LineStyle = xlContinuous
            ElseIf j = AnzahlSpalten Then
                ws.Cells(i, j).Borders(xlEdgeRight).LineStyle = xlContinuous
            End If
            
        Next j
            ws.Range(ws.Cells(i, 1), ws.Cells(i, AnzahlSpalten)).Borders(xlEdgeBottom).LineStyle = xlContinuous
    Next i
    With ws.Range("P1")
        .Value = AnzahlSpalten
        .Interior.Color = RGB(245, 158, 30)
    End With
End Sub

Sub Und()
    Dim AnzahlSpalten As Long
    Dim Zeile As Long
    Dim i As Long
    Dim ws As Worksheet
    Set ws = ActiveSheet
    AnzahlSpalten = ws.Range("P1").Value
    letzteZeile = 2 ^ AnzahlSpalten
    
    ' Überschriften für die Spalten erstellen
    ws.Cells(1, AnzahlSpalten + 2) = "Und"
    With ws.Cells(1, AnzahlSpalten + 2)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .Borders(xlBottom).LineStyle = xlContinuous
    End With
    
    'für jede Zeile die Spalten 1 - Anzahl Spalten mit And verknüpfen zB. =Und(A1:A3)
    For i = 2 To letzteZeile + 1
        ws.Cells(i, AnzahlSpalten + 2).Formula = "=AND(" & ws.Cells(i, 1).Address & ":" & ws.Cells(i, AnzahlSpalten).Address & ")"
        If ws.Cells(i, AnzahlSpalten + 2).Value Then
            ws.Cells(i, AnzahlSpalten + 2).Interior.Color = RGB(200, 255, 200) ' Hellgrün
        Else
            ws.Cells(i, AnzahlSpalten + 2).Interior.Color = RGB(255, 200, 200) ' Hellrot
        End If
    Next i
End Sub

Sub Oder()
    Dim AnzahlSpalten As Long
    Dim Zeile As Long
    Dim i As Long
    Dim ws As Worksheet
    Set ws = ActiveSheet
    AnzahlSpalten = ws.Range("P1").Value
    letzteZeile = 2 ^ AnzahlSpalten
    
    ' Überschriften für die Spalten erstellen
    ws.Cells(1, AnzahlSpalten + 3) = "Oder"
    With ws.Cells(1, AnzahlSpalten + 3)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .Borders(xlBottom).LineStyle = xlContinuous
    End With
    
    'für jede Zeile die Spalten 1 - Anzahl Spalten mit OR verknüpfen zB. =Oder(A1:A3)
    For i = 2 To letzteZeile + 1
        ws.Cells(i, AnzahlSpalten + 3).Formula = "=OR(" & ws.Cells(i, 1).Address & ":" & ws.Cells(i, AnzahlSpalten).Address & ")"
        If ws.Cells(i, AnzahlSpalten + 3).Value Then
            ws.Cells(i, AnzahlSpalten + 3).Interior.Color = RGB(200, 255, 200) ' Hellgrün
        Else
            ws.Cells(i, AnzahlSpalten + 3).Interior.Color = RGB(255, 200, 200) ' Hellrot
        End If
    Next i
End Sub

Sub ExOder()
    Dim AnzahlSpalten As Long
    Dim Zeile As Long
    Dim i As Long
    Dim ws As Worksheet
    Set ws = ActiveSheet
    AnzahlSpalten = ws.Range("P1").Value
    letzteZeile = 2 ^ AnzahlSpalten
    
    ' Überschriften für die Spalten erstellen
    ws.Cells(1, AnzahlSpalten + 4) = "XOR"
    With ws.Cells(1, AnzahlSpalten + 4)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .Borders(xlBottom).LineStyle = xlContinuous
    End With
    
    'für jede Zeile die Spalten 1 - Anzahl Spalten mit XOR verknüpfen zB. =XOder(A1:A3)
    For i = 2 To letzteZeile + 1
        ws.Cells(i, AnzahlSpalten + 4).Formula = "=XOR(" & ws.Cells(i, 1).Address & ":" & ws.Cells(i, AnzahlSpalten).Address & ")"
        If ws.Cells(i, AnzahlSpalten + 4).Value Then
            ws.Cells(i, AnzahlSpalten + 4).Interior.Color = RGB(200, 255, 200) ' Hellgrün
        Else
            ws.Cells(i, AnzahlSpalten + 4).Interior.Color = RGB(255, 200, 200) ' Hellrot
        End If
    Next i
End Sub

Sub Aequivalenz()
    Dim AnzahlSpalten As Long
    Dim Zeile As Long
    Dim i As Long
    Dim ws As Worksheet
    Set ws = ActiveSheet
    AnzahlSpalten = ws.Range("P1").Value
    letzteZeile = 2 ^ AnzahlSpalten
    
    ' Überschriften für die Spalten erstellen
    ws.Cells(1, AnzahlSpalten + 5) = "Äquivalenz"
    With ws.Cells(1, AnzahlSpalten + 5)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .Borders(xlBottom).LineStyle = xlContinuous
    End With

    For i = 2 To letzteZeile + 1
          Dim alleGleich As Boolean
          alleGleich = True
            
            
            ' Vergleiche alle Zellen in der Zeile
            For Spalte = 2 To AnzahlSpalten
                If ws.Cells(i, Spalte).Value <> ws.Cells(i, Spalte - 1).Value Then
                    alleGleich = False
                    Exit For ' Abbrechen, wenn ein Unterschied gefunden wurde
                End If
            Next Spalte
    
           '  Ergebnis in die Zielzelle schreiben
            ws.Cells(i, AnzahlSpalten + 5).Value = alleGleich
            
        'ws.Cells(i, AnzahlSpalten + 5).Formula = "=IF(" & ws.Cells(i, 1).Address & "=" & ws.Cells(i, 2).Address & ",TRUE,FALSE)"
        If ws.Cells(i, AnzahlSpalten + 5).Value Then
            ws.Cells(i, AnzahlSpalten + 5).Interior.Color = RGB(200, 255, 200) ' Hellgrün
        Else
            ws.Cells(i, AnzahlSpalten + 5).Interior.Color = RGB(255, 200, 200) ' Hellrot
        End If
    Next i
End Sub
Code-Sprache: VBScript (vbscript)

Schreibe einen Kommentar