MsgBox Auswertung sortieren

Option Explicit
Public MyName As String, Letzter, MyPass As String
Public Sub Auswertung2(Monat As String)
'dieses macro wertet das active Tabellenblatt aus und wehaelt den Tabellenblattnamen durch den   _
_
Commandbutton
Dim myMSG As String, MySchicht As String, MyRange As Range
Dim Myfind As Range, Cell As Object, FirstAddress As String
Dim i As Long, k As Long, NextFind As Boolean, CntLeer As Long
Dim MyArr(5)  'definiere Array fuer alle zu pruefenden Ressourcen, ggf. erweitern
'definiere zu suchenden Ressourcen
MyArr(0) = "Vorarbeiter"
MyArr(1) = "Schrumpfer"
MyArr(2) = "QS"
'MyArr(3) = "was auch immer"
'MyArr(4) = "XXX"
'MyArr(5) = "yyy"
'finde alle schichten
'Set MyRange = ActiveSheet.Range("A:$A")
myMSG = "Achtung" & vbCrLf
For k = LBound(MyArr) To UBound(MyArr)  'suche durch das Blatt fuer alle Eintraege im Array
If MyArr(k) = "" Then
'kein weiterer Eintrag, abbrechen
Exit For
End If
Set MyRange = ActiveSheet.Range("A:$A")
With MyRange
Set Myfind = .Find(what:="*" & MyArr(k) & "*", LookIn:=xlValues)
If Not Myfind Is Nothing Then
FirstAddress = Myfind.Address
MySchicht = Right(Myfind, Len(Myfind) - (Len(MyArr(k)) + 1))
If InStr(1, MySchicht, "S.")  0 Then
MySchicht = Left(MySchicht, Len(MySchicht) - 1) & "chicht"
End If
GoTo Schichtauswertung
find_again:
NextFind = True
Do
Set Myfind = .FindNext(Myfind)
If Not Myfind Is Nothing Then
If FirstAddress = Myfind.Address Then Exit Do
MySchicht = Right(Myfind, Len(Myfind) - (Len(MyArr(k)) + 1)) & "chicht" ' _
vbCrLf
GoTo Schichtauswertung
Return_Nextfind:
End If
Loop While Not Myfind Is Nothing And Myfind.Address  FirstAddress
NextFind = False
End If
End With
Next k
NextFind = False
GoTo show_result
Schichtauswertung:
Set MyRange = ActiveSheet.Range(Cells(Myfind.Row, 3), Cells(Myfind.Row, 33))
For Each Cell In MyRange
Debug.Print Cell.Value
If Cell.Text = 0 Then
myMSG = myMSG & "Am " & Day(Cells(1, Cell.Column).Value) & " " & Monat & " kein " & MyArr( _
_
k) & " in " & MySchicht & vbCrLf
ElseIf Cell.Text = "" And Cells(1, Cell.Column).Text  "" Then
CntLeer = CntLeer + 1
End If
Next Cell
If CntLeer  0 Then
myMSG = myMSG & "In " & MySchicht & " fehlen fuer " & MyArr(k) & " " & CntLeer & " eintraege! _
_
" & vbCrLf
CntLeer = 0
End If
If NextFind = True Then
GoTo Return_Nextfind
Else
GoTo find_again
End If
show_result:
If Len(myMSG)  7 And Len(myMSG)