Thema Datum  Von Nutzer Rating
Antwort
Rot VBA - Auswertung eines Rätsels funktioniert nicht
21.06.2021 15:02:01 Kristiane
NotSolved
21.06.2021 15:29:01 Der Steuerfuzzi
NotSolved

Ansicht des Beitrags:
Von:
Kristiane
Datum:
21.06.2021 15:02:01
Views:
98
Rating: Antwort:
  Ja
Thema:
VBA - Auswertung eines Rätsels funktioniert nicht

Hallo, 

ich möchte ein altes Excel-Rätsel aus dem Jahr 2006 wiederbeleben. Leider läuft das Makro in Excel 2016 nicht mehr. Es stockt an der unten gelb markierten Postition. 

Kann jemand helfen?

Vielen Dank

Kristiane 

************************************

Sub Gesamttest_auswerten()

    ActiveSheet.Unprotect Password:=Sheets(Sheets.Count).Cells(2, 12)

    ActiveSheet.Cells(39, 2) = ""

    Dim richtig(9) As Integer
    Dim zähler(9) As Integer
    ergebnis = 0
    gesamtaufgaben = 0
    blatt = 0

    For i = 0 To 9
        richtig(i) = 0
        zähler(i) = 0
    Next


    For i = 0 To Sheets.Count - 2

        For j = 0 To 9
    
            'Gesamtzahl der Fragen ermitteln
            If Not Sheets(i + 1).Cells(8 + j * 17, 4) = 0 Then gesamtzahl = gesamtzahl + 1
    
            'Einzelantworten bestimmen
            Sheets(i + 1).OLEObjects("klar" & j).Object.Value = True
            If Sheets(i + 1).Cells(16 + j * 17, 9) = Sheets(Sheets.Count).Cells(4, 12) Then
                richtig(i) = richtig(i) + 1
            End If
        
            'zählen wie viele Antworten insgesamt ausgewählt wurden
            If Sheets(i + 1).OLEObjects("a" & j).Object.Value Then zähler(i) = zähler(i) + 1
            If Sheets(i + 1).OLEObjects("b" & j).Object.Value Then zähler(i) = zähler(i) + 1
            If Sheets(i + 1).OLEObjects("c" & j).Object.Value Then zähler(i) = zähler(i) + 1
        
        Next
    
        gesamtaufgaben = gesamtaufgaben + zähler(i)
    
        'Summe der Teilergebnisse zählen
        If zähler(i) > 0 Then
            ergebnis = ergebnis + richtig(i) / zähler(i)
            blatt = blatt + 1
        End If
 
        Sheets(Sheets.Count).Cells(5 + i * 3, 17) = zähler(i)
        Sheets(Sheets.Count).Cells(6 + i * 3, 17) = richtig(i)
    
    Next

    'Durschnitt der Teilergebnisse bilden
    If blatt > 0 Then ergebnis = ergebnis / blatt Else ergenis = 0
    
    'Antwortblock wählen, denn dieser ist abhängig von der Gesamtzahl der Antworten
    If summe < gesamtzahl Then block = 0 Else block = 1

    'Auswertungstext auswählen
    If Not gesamtaufgaben = 0 Then
        Select Case ergebnis
            Case Is <= 0.2: Sheets(Sheets.Count).Cells(39, 2) = Sheets(Sheets.Count).Cells(8 + 17 * block, 12)
            Case Is <= 0.4: Sheets(Sheets.Count).Cells(39, 2) = Sheets(Sheets.Count).Cells(11 + 17 * block, 12)
            Case Is <= 0.6: Sheets(Sheets.Count).Cells(39, 2) = Sheets(Sheets.Count).Cells(14 + 17 * block, 12)
            Case Is <= 0.8: Sheets(Sheets.Count).Cells(39, 2) = Sheets(Sheets.Count).Cells(17 + 17 * block, 12)
            Case Else: Sheets(Sheets.Count).Cells(39, 2) = Sheets(Sheets.Count).Cells(20 + 17 * block, 12)
        End Select
    End If


    ActiveSheet.Protect Password:=Sheets(Sheets.Count).Cells(2, 12)


End Sub


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:

 
 

  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot VBA - Auswertung eines Rätsels funktioniert nicht
21.06.2021 15:02:01 Kristiane
NotSolved
21.06.2021 15:29:01 Der Steuerfuzzi
NotSolved