VBA nach Überschriften suchen, kopieren & löschen

Sub Maengelliste_TEST()
Dim oXlSM As Workbook, oXML As Workbook
Dim nIndexXLSM, nIndexXML, 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", "  _
_
Gewerkegruppe", "Gewerk", "Level A", "Level B", "Level C", "Level D", "Raum", "Achse", "Foto", " _
Frist", "Nachfrist", "letzte Nachfrist", "Auftragnehmer", "funktional", "Vorbereitung der Abnahme", "sicherheits-relevant", "Restleistung", "optisch", "Anspruch unsicher")
ArrayZiel = Array("betrifft", "Zustandsbeschreibung", "Mangelart", "Vertragsart", " _
Gewerkegruppe", "Gewerk", "Level A", "Level B", "Level C", "Level D", "Raum", "Achse", "Foto", " _
Frist", "Nachfrist", "letzte Nachfrist", "Auftragnehmer", "funktional", "Vorbereitung der Abnahme", "sicherheits-relevant", "Restleistung", "optisch", "Anspruch unsicher")
'hier wird festgelegt welche Datei geöffnet werden soll und wo diese gespeichert ist
Set oXML = Workbooks.Open(Filename:= _
"\\c\0000 Intern\0000 Mangeltool\Muster\VORLAGE Zustandsbeschreibung.xml")
Set oXlSM = ThisWorkbook 'ThisWorkbook = die xlsm-Datei, in der dieser Code steht

Option Explicit
Sub copyAndDelete()
Dim objWbMaster As Workbook, objWbArchiv As Workbook
Dim objShSrc As Worksheet, objShTgt As Worksheet
Dim rng As Range, rngCopy As Range
Dim strFileArchiv As String, strFirst As String, strMsg As String
Dim lngNext As Long
Dim blnOpen As Boolean
On Error GoTo ErrExit
strFileArchiv = "\\C:\0000 Intern\0000 Mangeltool\Muster\VORLAGE Zustandsbeschreibung.xml" '  _
_
Pfad und Name der Uploaddatei Anpassen!
Set objWbMaster = ThisWorkbook
Set objShSrc = objWbMaster.Sheets("Mängel vor der Abnahme") 'Tabellenname in 'Gesamtliste  _
anpassen' - Anpassen!
Set rng = objShSrc.Range("A:A").Find(What:="ja", LookAt:=xlWhole, _
LookIn:=xlValues, MatchCase:=False, After:=objShSrc.Range("A" & Rows.Count))
If Not rng Is Nothing Then
strFirst = rng.Address
Do
If rngCopy Is Nothing Then
Set rngCopy = rng.EntireRow
Else
Set rngCopy = Union(rngCopy, rng.EntireRow)
End If
Set rng = objShSrc.Range("A:A").FindNext(rng)
Loop While Not rng Is Nothing And strFirst  rng.Address
End If
If Not rngCopy Is Nothing Then
For Each objWbArchiv In Application.Workbooks
If objWbArchiv.FullName = strFileArchiv Then Exit For
Next
If objWbArchiv Is Nothing Then
Set objWbArchiv = Workbooks.Open(strFileArchiv)
blnOpen = True
End If
Set objShTgt = objWbArchiv.Sheets("neue Zustandsbeschreibungen") 'Tabellenname in ' _
Uploaddatei' - Anpassen!
With objShTgt
lngNext = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
rngCopy.Copy .Cells(lngNext, 1)
End With
If blnOpen Then
objWbArchiv.Close True
Else
objWbArchiv.Save
End If
strMsg = rngCopy.Rows.Count
rngCopy.Delete
objWbMaster.Save
MsgBox "Es wurden " & strMsg & " Datensätze übertragen!", vbInformation, "Hinweis"
Else
MsgBox "Es wurden keine Datensätze gefunden!", vbInformation, "Hinweis"
End If
ErrExit:
If Err.Number > 0 Then
MsgBox "Fehlernummer:" & vbTab & Err.Number & vbLf & vbLf & _
"Fehlertext:" & vbTab & Err.Description, vbExclamation, "Fehler"
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Set objShSrc = Nothing
Set objShTgt = Nothing
Set objWbMaster = Nothing
Set objWbArchiv = Nothing
Set rng = Nothing
Set rngCopy = Nothing
End Sub