Makro übertragen und abändern

Sub Schicht_eintr()
Dim sArr, i%, s As Byte, x$, a As Byte, wt As Byte
Dim w As Byte, z As Byte
sArr = Array("I", "II", "Sp", "III", "D")
On Error GoTo ende
With Selection
x = .Value
i = 5
s = .Column
End With
Select Case x
Case sArr(0): a = 0
Case sArr(1): a = 1
Case sArr(2): a = 2
Case sArr(3): a = 3
Case sArr(4): a = 4
End Select
With ActiveSheet
wt = Weekday(.Cells(i, s - 4))
If Selection.Value = "II" And wt = 2 Then Exit Sub
If a = 1 And wt = 1 Then
Cells(i, s) = sArr(4)
i = i + 1
a = a + 1
End If
If wt = 2 Then a = a + 1
If a = 5 Then a = 0
If a = 1 Then z = 7 Else: z = 1
If wt = 1 Then z = 1
Do
.Cells(i, s) = sArr(a)
wt = Weekday(.Cells(i, s - 4))
i = i + 1
Loop Until wt = z
If a = 1 Then
.Cells(i, s) = sArr(4)
i = i + 1
End If
a = a + 1
If a = 5 Then a = 0
If a = 1 Then w = i - 1 Else: w = i
Do Until i = w + 7
.Cells(i, s) = sArr(a)
i = i + 1
Loop
If a = 1 Then
.Cells(i, s) = sArr(4)
i = i + 1
End If
a = a + 1
If a = 5 Then a = 0
If a = 1 Then w = i - 1 Else: w = i
Do Until i = w + 7
.Cells(i, s) = sArr(a)
i = i + 1
Loop
If a = 1 Then
Cells(i, s) = sArr(4)
i = i + 1
End If
a = a + 1
If a = 5 Then a = 0
If a = 1 Then w = i - 1 Else: w = i
Do Until i = w + 7
.Cells(i, s) = sArr(a)
i = i + 1
Loop
If a = 1 Then
Cells(i, s) = sArr(4)
i = i + 1
End If
a = a + 1
If a = 5 Then a = 0
If a = 1 Then w = i - 1 Else: w = i
Do Until i = w + 7
.Cells(i, s) = sArr(a)
i = i + 1
If i > 34 Then GoTo weiter
Loop
If a = 1 Then
.Cells(i, s) = sArr(4)
i = i + 1
End If
a = a + 1
If a = 5 Then a = 0
If a = 1 Then w = i - 1 Else: w = i
Do Until i > 35
.Cells(i, s) = sArr(a)
i = i + 1
Loop
weiter:
For i = 32 To 34
If Cells(i, s - 3) = "" Then
Cells(i, s) = ""
End If
Next
End With'
ende:
End Sub