funktionierendes Makro umschreiben

Sub Standard_Maengelliste()
Dim oXlSM As Workbook, oXML As Workbook
Dim nIndexXLSM, nIndexXLM, MaxRow As Long, nIndex As Long
Dim rngXLSM As Range, rngXML As Range, ArrayXLSM
Dim strFehler As String
Dim ArrayQuelle, ArrayZiel
Const sListZeichen$ = "• "
'hier stehen die Überschriften, nach denen gesucht wird
'Wichtig! Die Reihenfolge muss bei beiden identisch sein
ArrayQuelle = Array("Betrifft", "verortete Zustandsbeschreibung", "Mangelart", "Vertragsart", " _
Gewerke-gruppe", "Gewerk", "Bauteil", "Geschoss", "Level C", "Level D", "Raum", "Achse", "Foto", "Frist", "Nachfrist", "letzte Nachfrist", "Auftragnehmer", "funktional", "Vorbereitung der Abnahme", "sicherheitsrelevant", "Restleistung", "Anspruch unsicher")
ArrayZiel = Array("betrifft", "Zustandsbeschreibung", "Mangelart", "Vertragsart", " _
Gewerkegruppe", "Gewerk", "Bauteil", "Geschoss", "Level C", "Level D", "Raum", "Achse", "Foto", "Frist", "Nachfrist", "letzte Nachfrist", "Auftragnehmer", "funktional", "Vorbereitung der Abnahme", "sicherheitsrelevant", "Restleistung", "Anspruch unsicher")
'hier wird festgelegt welche Datei geöffnet werden soll und wo diese gespeichert ist
Set oXML = Workbooks.Open(Filename:= _
"\\xxx.xxx.xx.x\xxx-xxxxxxxx\xxxxxxxx\xxxx\xx-xx xxx\xxxx xxxxxx\" & _
"xxxx xxxxxx\xxx xxxxxxx xxxxxxxxxx.xml")
Set oXlSM = ThisWorkbook 'ThisWorkbook = die xlsm-Datei, in der dieser Code steht
For nIndex = LBound(ArrayQuelle) To UBound(ArrayQuelle)
With oXlSM.Sheets("Mängel vor der Abnahme") 'Name des Tabellenblattes, welches in der xlsm- _
Datei benutzt wird
nIndexXLSM = Application.Match(ArrayQuelle(nIndex), .Rows(2), 0) 'sucht in der Zeile 2  _
nach den Spaltenbeschriftungen
If IsNumeric(nIndexXLSM) Then
MaxRow = .Cells(.Rows.Count, nIndexXLSM).End(xlUp).Row 'letzte Zeile in Spalte
Set rngXLSM = .Range(.Cells(3, nIndexXLSM), .Cells(MaxRow, nIndexXLSM))
If MaxRow > 3 Then
ArrayXLSM = rngXLSM
ElseIf MaxRow = 3 Then
ArrayXLSM = rngXLSM.Resize(, 2)
ReDim Preserve ArrayXLSM(1 To UBound(ArrayXLSM), 1 To 1)
End If
'Fehlermeldung die ausgegeben wird, wenn eine festgelegte Spaltenüberschrift nicht  _
in der xlsm-Datei gefunden werden konnte
strFehler = strFehler & sListZeichen & "Die Spalte'" & _
ArrayQuelle(nIndex) & "' wurde nicht in der Quell-Datei gefunden" &  _
vbCr
End If
End With
If IsArray(ArrayXLSM) Then
With oXML.Sheets("neue Zustandsbeschreibungen") 'Name des Tabellenblattes, welches in  _
der xml-Datei benutzt wird
nIndexXML = Application.Match(ArrayZiel(nIndex), .Rows(21), 0) 'sucht in der Zeile  _
21 nach den Spaltenbeschriftungen
If IsNumeric(nIndexXLM) Then
'alle Inhalte der Zellen ab Zeile 22 werden für neue Daten gelöscht
.Range(.Cells(22, nIndexXML), .Cells(.Rows.Count, nIndexXML)).ClearContents
Set rngXLM = .Cells(22, nIndexXML) 'erste Einfügezelle
rngXLM.Resize(UBound(ArrayXLSM), 1) = ArrayXLSM 'Daten aus Array einfügen
Else
strFehler = strFehler & sListZeichen & "Die Spalte'" & _
ArrayZiel(nIndex) & "' wurde nicht in der Ziel-Datei gefunden" &  _
vbCr
End If
End With
End If
ArrayXLSM = Empty
Next nIndex
Dim Sh_neue_Zustandsbeschreibungen As Worksheet
Dim iCalc As Long
On Error GoTo ErrExit
Set Sh_neue_Zustandsbeschreibungen = Sheets("neue Zustandsbeschreibungen") 'hier wird das  _
Tabellenblatt beschrieben, wo die Leerzeilen gelöscht werden sollen
With Application
iCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'hier erfolgt die Abschaltung des Blattschutzes
With Sh_neue_Zustandsbeschreibungen
.Unprotect
'hier werden Zeilen die komplett leer sind gelöscht
With .UsedRange.Columns(.UsedRange.Columns.Count).Offset(0, 1)
.FormulaR1C1 = "=IF(AND(ROW()>22,RC1&RC2=""""),TRUE(),ROW())"
Sh_neue_Zustandsbeschreibungen.UsedRange.Sort .Cells(1, 1), xlAscending, , , , , , xlNo
On Error Resume Next
.SpecialCells(xlCellTypeFormulas, 4).EntireRow.Delete
On Error GoTo ErrExit
.EntireColumn.Delete
End With
'hier wird der Blattschutz wieder aktiviert
.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
:=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _
AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
AllowUsingPivotTables:=True
End With
ErrExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = iCalc
End With
Set Sh_neue_Zustandsbeschreibungen = Nothing
'hier erfolgt die Prüfung nach ggf. vergessenen Zellen
Dim zeile As Long, spalte As Long
Dim i As Integer
Dim strausgabe As String, strzelle As String, x As String
Dim wks As Worksheet
Dim check As Boolean
Set wks = Sheets(1)
Dim spalten()
Dim spaltennamen()
Dim spaltenausgabe()
x = ""
spalten() = Array(5, 6, 7, 15, 18)
spaltennamen() = Array("In der Spalte Mangelart (E)", "In der Spalte Vertragsart (F)", "In der  _
Spalte Gewerk (G)", "In der Spalte Frist (O)", "In der Spalte Auftragnehmer (R)")
spaltenausgabe() = Array(x, x, x, x, x, x, x, x)
For i = 0 To UBound(spalten())
spaltenausgabe(i) = spaltennamen(i) & " in den Zeilen: "
Next i
With wks
For zeile = 22 To 500
If .Cells(zeile, 2).Value  "" Then
For i = 0 To UBound(spalten())
On Error GoTo schleife
If Cells(zeile, spalten(i)).Value = 0 Then
schleife:
spaltenausgabe(i) = spaltenausgabe(i) & vbCrLf & zeile & ",  " & vbCrLf
check = True
End If
Next i
End If
Next zeile
End With
If check = True Then
For i = 0 To UBound(spalten())
strausgabe = strausgabe & spaltenausgabe(i) & vbCrLf
Next i
MsgBox "Fehlerhaft ausgefüllte Zellen: " & vbCrLf & vbCrLf & _
strausgabe
Else
MsgBox "Es konnten keine leeren Zellen in den Spalten Mangelart (E), Vertragsart (F),  _
Gewerk (G), Frist (O) und Auftragnehmer (R) gefunden werden!"
End If
'Spalte Frist = Datumsformat
Columns("O:O").Select
Selection.NumberFormat = "dd/mm/yyyy"
'speichern der xlm-Datei
Dim Dateiname As String
Dateiname = Left(oXlSM.Name, Len(oXlSM.Name) - 5)
ActiveWorkbook.SaveAs Filename:="\\xxx.xxx.xx.x\xxx-xxxxxxxx\xxxxxxxx\xxxx\xx-xx xxx\xxxx  _
xxxxxx\xxxx xx xxxxx\xxxx\" & Dateiname & ".xml"
End Sub