Option Explicit
Dim Kopf_Zeile As Integer, Kopf_Spalte As Integer
Dim Letzte_Zeile As Integer, Letzte_Spalte As Integer
Dim Laenge() As String
  
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
  
     
  
Sub Snake()
'====================================================================
'Alles Löschen und Spaltenbreite und -höhe anpassen
'====================================================================
  
    Cells.Select
    Selection.ClearContents
    Range("A1").Select
  
    Cells.Select
    Selection.ClearFormats
    Range("A1").Select
  
    Cells.Select
    Selection.RowHeight = 12
    Selection.ColumnWidth = 2.5
    Range("A1").Select
     
'====================================================================
'Spielbereich festlegen
'====================================================================
  
    Range("J10:AM39").Select
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
    End With
'====================================================================
'Snake entstehen lassen
'====================================================================
    Dim Groesse As Integer, a As Boolean
    Groesse = 5
     
    Range("V24:Z24").Select
    Selection.Interior.Color = 5287936
     
        ReDim Laenge(4)
        Laenge(0) = "V24"
        Laenge(1) = "W24"
        Laenge(2) = "X24"
        Laenge(3) = "Y24"
        Laenge(4) = "Z24"
     
    Range("V24").Select
    Letzte_Spalte = ActiveCell.Column
    Letzte_Zeile = ActiveCell.Row
     
    Range("Z24").Select
    Kopf_Spalte = ActiveCell.Column
    Kopf_Zeile = ActiveCell.Row
     
    Application.OnKey "{RIGHT}", "Rechts"
    Application.OnKey "{UP}", "Rauf"
    Application.OnKey "{DOWN}", "Runter"
    Application.OnKey "{LEFT}", "Links"
     
End Sub
Sub Rechts()
Dim j As Integer
On Error GoTo Fehler
Application.OnTime Now + TimeValue("00:00:01"), "Rechts", , False
Application.OnTime Now + TimeValue("00:00:01"), "Rauf", , False
Application.OnTime Now + TimeValue("00:00:01"), "Runter", , False
Application.OnTime Now + TimeValue("00:00:01"), "Links", , False
  
            Range(Laenge(0)).Select
             
            Selection.Interior.Pattern = xlNone
             
            For j = 0 To (UBound(Laenge)) - 1
     
               Laenge(j) = Laenge(j + 1)
     
            Next j
             
            Range(Laenge(4)).Select
            ActiveCell.Offset(0, 1).Select
            Selection.Interior.Color = 5287936
            Laenge(4) = ActiveCell.Address
  
             
            If Selection.Borders(xlEdgeLeft).Weight = xlMedium Then
                MsgBox ("Verloren!!!!!!!")
                Application.OnTime Now + TimeValue("00:00:01"), "Rechts", , False
                Application.OnKey "{RIGHT}"
                Application.OnKey "{UP}"
                Application.OnKey "{DOWN}"
                Application.OnKey "{LEFT}"
                Exit Sub
            End If

Application.OnTime Now + TimeValue("00:00:01"), "Rechts", , True
Exit Sub
Fehler:
Err.Clear
Resume Next
End Sub
  
Sub Links()
On Error GoTo Fehler
Application.OnTime Now + TimeValue("00:00:01"), "Rechts", , False
Application.OnTime Now + TimeValue("00:00:01"), "Rauf", , False
Application.OnTime Now + TimeValue("00:00:01"), "Runter", , False
Application.OnTime Now + TimeValue("00:00:01"), "Links", , False
    
    Dim j As Integer
             
            Range(Laenge(0)).Select
            Range(Laenge(0)).Select
            Selection.Interior.Pattern = xlNone
             
            For j = 0 To (UBound(Laenge)) - 1
     
               Laenge(j) = Laenge(j + 1)
     
            Next j
             
            Range(Laenge(4)).Select
            ActiveCell.Offset(0, -1).Select
            Selection.Interior.Color = 5287936
            Laenge(4) = ActiveCell.Address
             
            If Selection.Borders(xlEdgeRight).Weight = xlMedium Then
                MsgBox ("Verloren!!!!!!!")
                Application.OnTime Now + TimeValue("00:00:01"), "Links", , False
                Application.OnKey "{RIGHT}"
                Application.OnKey "{UP}"
                Application.OnKey "{DOWN}"
                Application.OnKey "{LEFT}"
                Exit Sub
            End If

Application.OnTime Now + TimeValue("00:00:01"), "Links", , True
Exit Sub
Fehler:
Err.Clear
Resume Next
     
End Sub
  
Sub Rauf()
On Error GoTo Fehler
Application.OnTime Now + TimeValue("00:00:01"), "Rechts", , False
Application.OnTime Now + TimeValue("00:00:01"), "Rauf", , False
Application.OnTime Now + TimeValue("00:00:01"), "Runter", , False
Application.OnTime Now + TimeValue("00:00:01"), "Links", , False
     
    Dim j As Integer
             
            Range(Laenge(0)).Select
            Selection.Interior.Pattern = xlNone
             
            For j = 0 To (UBound(Laenge)) - 1
     
               Laenge(j) = Laenge(j + 1)
     
            Next j
             
            Range(Laenge(4)).Select
            ActiveCell.Offset(-1, 0).Select
            Selection.Interior.Color = 5287936
            Laenge(4) = ActiveCell.Address
            If Selection.Borders(xlEdgeBottom).Weight = xlMedium Then
                MsgBox ("Verloren!!!!!!!")
                Application.OnTime Now + TimeValue("00:00:01"), "Rauf", , False
                Application.OnKey "{RIGHT}"
                Application.OnKey "{UP}"
                Application.OnKey "{DOWN}"
                Application.OnKey "{LEFT}"
                Exit Sub
            End If
Application.OnTime Now + TimeValue("00:00:01"), "Rauf", , True

Exit Sub
Fehler:
Err.Clear
Resume Next
End Sub

  
Sub Runter()
On Error GoTo Fehler
Application.OnTime Now + TimeValue("00:00:01"), "Rechts", , False
Application.OnTime Now + TimeValue("00:00:01"), "Rauf", , False
Application.OnTime Now + TimeValue("00:00:01"), "Runter", , False
Application.OnTime Now + TimeValue("00:00:01"), "Links", , False
     
    Dim j As Integer
  
             
            Range(Laenge(0)).Select
            Selection.Interior.Pattern = xlNone
             
            For j = 0 To (UBound(Laenge)) - 1
     
               Laenge(j) = Laenge(j + 1)
     
            Next j
             
            Range(Laenge(4)).Select
            ActiveCell.Offset(1, 0).Select
            Selection.Interior.Color = 5287936
            Laenge(4) = ActiveCell.Address
            If Selection.Borders(xlEdgeTop).Weight = xlMedium Then
                MsgBox ("Verloren!!!!!!!")
                Application.OnTime Now + TimeValue("00:00:01"), "Runter", , False
                Application.OnKey "{RIGHT}"
                Application.OnKey "{UP}"
                Application.OnKey "{DOWN}"
                Application.OnKey "{LEFT}"
                Exit Sub
            End If
Application.OnTime Now + TimeValue("00:00:01"), "Runter", , True

Exit Sub
Fehler:
Err.Clear
Resume Next
End Sub