2 z. T. idenische Makros zu einem zusammenfassen

Sub Standard_Maengelliste()
Dim oXlSM As Workbook, oXML As Workbook, oXLSX As Workbook
Dim nIndexXLSM, nIndexXML, nIndexXLSX, MaxRow As Long, nIndex As Long
Dim rngXLSM As Range, rngXML As Range, rngXLSX 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", "Bauabschnitt", _
"Geschoss", "Nutzung", "Bereich", "Raum", "Achse", "Foto", "Frist", "Nachfrist", "letzte  _
Nachfrist", "Auftragnehmer", "strittig", _
"sicherheitsrelevant", "betriebsrelevant", "optisch", "Restleistung", "Anspruch unsicher", " _
Nachweis fehlt")
ArrayZiel = Array("betrifft", "Zustandsbeschreibung", "Mangelart", "Vertragsart", " _
Gewerkegruppe", "Gewerk", "Bauabschnitt", "Geschoss", _
"Nutzung", "Bereich", "Raum", "Achse", "Foto", "Frist", "Nachfrist", "letzte Nachfrist", " _
Auftragnehmer", "strittig", "sicherheitsrelevant", _
"betriebsrelevant", "optisch", "Restleistung", "Anspruch unsicher", "Nachweis fehlt")
'hier wird festgelegt welche Datei geöffnet werden soll und wo diese gespeichert ist
Set oXML = Workbooks.Open(Filename:= _
"\\xxxxxxxxx\" & _
"0000 MUSTER\VORLAGE Zustandsbeschreibung.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(64), 0) 'sucht in der Zeile  _
64 nach den Spaltenbeschriftungen
If IsNumeric(nIndexXML) Then
'alle Inhalte der Zellen ab Zeile 65 werden für neue Daten gelöscht
.Range(.Cells(65, nIndexXML), .Cells(.Rows.Count, nIndexXML)).ClearContents
Set rngXML = .Cells(65, nIndexXML) 'erste Einfügezelle
rngXML.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()>65,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 = 65 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 xml-Datei
Dim Dateiname As String
Dateiname = Left(oXlSM.Name, Len(oXlSM.Name) - 5)
ActiveWorkbook.SaveAs Filename:="\\xxx\Dokumentation\" & Dateiname _
& ".xml"
End Sub

Sub Standard_Maengelliste_MB()
Dim oXlSM As Workbook, oXLSX As Workbook
Dim nIndexXLSM, nIndexXLSX, MaxRow As Long, nIndex As Long
Dim rngXLSM As Range, rngXLSX 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", "Gewerke-gruppe", " _
Bauabschnitt", "Geschoss", "Nutzung", "Bereich", "Raum", _
"Achse", "Frist")
ArrayZiel = Array("betrifft", "Zustandsbeschreibung", "Gewerk", "Bauabschnitt", "Geschoss", " _
Nutzung", "Bereich", "Raum", "Achse", "Frist")
'hier wird festgelegt welche Datei geöffnet werden soll und wo diese gespeichert ist
Set oXLSX = Workbooks.Open(Filename:= _
"\\xxx\0000 Intern\" & _
"0000 MUSTER\VORLAGE Info-Datei MB-Ergebnis.xlsx")
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 oXLSX.Sheets("Mängel vor der Abnahme") 'Name des Tabellenblattes, welches in der  _
xlsx-Datei benutzt wird
nIndexXLSX = Application.Match(ArrayZiel(nIndex), .Rows(2), 0) 'sucht in der Zeile  _
2 nach den Spaltenbeschriftungen
If IsNumeric(nIndexXLSX) Then
'alle Inhalte der Zellen ab Zeile 3 werden für neue Daten gelöscht
.Range(.Cells(3, nIndexXLSX), .Cells(.Rows.Count, nIndexXLSX)).ClearContents
Set rngXLSX = .Cells(3, nIndexXLSX) 'erste Einfügezelle
rngXLSX.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
'Spalte Frist = Datumsformat
Columns("K:K").Select
Selection.NumberFormat = "dd/mm/yyyy"
'speichern der xlsx-Datei
Dim Dateiname As String
Dateiname = Left(oXlSM.Name, Len(oXlSM.Name) - 5)
ActiveWorkbook.SaveAs Filename:="\\xxx\Dokumentation\" & _
Dateiname & " MB" & ".xml"
End Sub