zuerst einmal "EIN FROHES UND GESUNDES NEUS JAHR!!!"....
Ich bin schon wieder einmal dringend auf Eure Hilfe angewiesen.
Dank Euch habe ich folgendes Makro:
Option Explicit
Sub Maengelliste_SKH()
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", "Bauteil", "Geschoss", _
"Nutzung", "Level D", "Raum", "Achse", "Foto", "Frist", "Nachfrist", "letzte Nachfrist", " _
Auftragnehmer", "betriebsrelevant", "Vorbereitung der Abnahme", _
"VL AG", "sicherheitsrelevant", "Restleistung", "Bauherr", "optisch", "Anspruch unsicher", " _
Nachweis fehlt")
ArrayZiel = Array("betrifft", "Zustandsbeschreibung", "Mangelart", "Vertragsart", " _
Gewerkegruppe", "Gewerk", "Bauteil", "Geschoss", "Nutzung", _
"Level D", "Raum", "Achse", "Foto", "Frist", "Nachfrist", "letzte Nachfrist", "Auftragnehmer", " _
betriebsrelevant", "Vorbereitung der Abnahme", _
"VL AG", "sicherheitsrelevant", "Restleistung", "Bauherr", "optisch", "Anspruch unsicher", " _
Nachweis fehlt")
'hier wird festgelegt welche Datei geöffnet werden soll und wo diese gespeichert ist
Set oXML = Workbooks.Open(Filename:= _
"\\PFAD\" & _
"0000 MUSTER\Mangelerfassung\SKH 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
Else
strFehler = strFehler & sListZeichen & "Die Spalte '" & _
ArrayQuelle(nIndex) & "' wurde nicht in der Quell-Datei gefunden." & vbCr
MsgBox strFehler
Exit Sub
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(27), 0) 'sucht in der Zeile 27 _
nach den Spaltenbeschriftungen
If IsNumeric(nIndexXML) Then
'alle Inhalte der Zellen ab Zeile 28 werden für neue Daten gelöscht
.Range(.Cells(28, nIndexXML), .Cells(.Rows.Count, nIndexXML)).ClearContents
Set rngXML = .Cells(28, 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
MsgBox strFehler
Exit Sub
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()>28,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(1, 2, 9, 10, 11, 12, 13, 14, 16, 19)
spaltennamen() = Array( _
"In der Spalte Bauteil (A)", _
"In der Spalte Geschoss (B)", _
"In der Spalte Betrifft (I)", _
"In der Spalte Zustandsbeschreibung (J)", _
"In der Spalte Mangelart (K)", _
"In der Spalte Vertragsart(L)", _
"In der Spalte Gewerkegruppe(M)", _
"In der Spalte Gewerk(O)", _
"In der Spalte Frist(Q)", _
"In der Spalte Auftragnehmer(T)")
spaltenausgabe() = Array(x, x, 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 = 28 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
Exit Sub
Else
MsgBox "Es konnten keine leeren Zellen in den Spalten Bauteil (A), Geschoss (B), Betrifft ( _
I), Zustandsbeschreibung (J), Mangelart (K), Vertragsart(L), Gewerkegruppe(M), Gewerk(O), Frist(Q), und Auftragnehmer(T) 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)
Dim vntFilename As Variant
vntFilename = "\\PFAD\" & DateiName & ".xml"
On Error Resume Next
Do
Err.Clear
ActiveWorkbook.SaveAs vntFilename
If Err Then
Do
vntFilename = Application.GetSaveAsFilename
Loop While vntFilename = False
End If
Loop While Err
Maengelliste_SKH_MB
End Sub
Sub Maengelliste_SKH_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", "Gewerk", "Bauteil", " _
Geschoss", "Nutzung", "Raum", "Achse", "Frist")
ArrayZiel = Array("betrifft", "Zustandsbeschreibung", "Gewerk", "Bauteil", "Geschoss", " _
Nutzung", "Raum", "Achse", "Frist")
'hier wird festgelegt welche Datei geöffnet werden soll und wo diese gespeichert ist
Set oXLSX = Workbooks.Open(Filename:= _
"\\PFAD\SKH 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
oXLSX.Sheets("Mängel vor der Abnahme").Range("C1") = oXlSM.Sheets("Mängel vor der Abnahme"). _
Range("C1")
'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)
Dim vntFilename As Variant
vntFilename = "\\PFAD\ " & DateiName & " MB" & ".xlsx"
On Error Resume Next
Do
Err.Clear
ActiveWorkbook.SaveAs vntFilename
If Err Then
Do
vntFilename = Application.GetSaveAsFilename
Loop While vntFilename = False
End If
Loop While Err
End Sub
Das anzupassen habe ich immer hinbekommen. Jetzt gibt es aber eine Änderung die ich alleine nicht hinbekomme.
Die Prüfung nach nicht ausgefüllten Zellen erfolgt nach Erstellung der XML-Datei in dieser.
Ich möchte gerne, dass erst die Prüfung (innerhalb der xlsm-Liste) erfolgt und bei Fehlerfreiheit die XML-Datei erstellt und gespeichert wird. Sollten Fehler vorhanden sein, dann soll die Erstellung der XML-Datei abgebrochen werden.
Desweiteren wäre es schön, wenn nicht nur die Msg-Box erscheint, sondern das die fehlenden Zellen farblich unterlegt werden. Ist aber kein Muss, sondern nur ein nettes Bonbon. :)
Was ich auch nicht gut finde ist dieser Teil:
'Spalte Frist = Datumsformat
Columns("O:O").Select
Selection.NumberFormat = "dd/mm/yyyy"
Geht das nicht anders? Diese Ausführung kann man nämlich sehen.
Könnt Ihr mir hierzu helfen?
Vielen Dank!
Viele Grüße
Sandra