suche n. letz. ausgefüllte Zeile; autom. Speichern

Option Explicit
Sub prc_Testen_Copy_and_Delete2()
If fncTesten = True Then
Call prcCopyAndDelete
Else
'do nothing, es gibt Zellen mit fehlenden Werten
End If
End Sub
Sub Password()
Dim strInput As String
strInput = InputBox("Zum Übertragen der Mängel in die Gesamtliste geben Sie bitte das  _
entsprechende Passwort ein.", "Passwort")
If strInput = "" Then Exit Sub
If strInput = "0123+++" Then
Call prcCopyAndDelete2
Else
MsgBox "Dieses Passwort ist falsch!", vbExclamation, "Fehler"
End If
End Sub
Private Sub prcCopyAndDelete2()
Dim objWbMaster As Workbook, objWbArchiv As Workbook
Dim objShSrc As Worksheet, objShTgt As Worksheet
Dim rng As Range, rngCopy As Range
Dim strPfad As String, strFileArchiv As String, strFirst As String, strMsg As String
Dim lngNext As Long, lngZeileTgt As Long
Dim varTest As Variant
Dim arrSpalten() As Long
Dim arrSpaltenSource
Dim arrSpaltenTarget
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Pfad und Name der Vorlagedatei                                          ggf. anpassen!
strFileArchiv = "\0000 Intern\0200 Doku\0274 Mangeltool\Erfassung\_
Gesamtliste zur Mangelerfassung.xlsm"
'Verzeichnis für erstellte Datei                                        - ggf. Anpassen
strPfad = "\0000 Intern\0200 Doku\0274 Mangeltool\Erfassung"
Set objWbMaster = ThisWorkbook '=Datei mit Gesamtliste
'Tabellenname in Gesamtliste                                       - Name ggf anpassen!
Set objShSrc = objWbMaster.Sheets("Mängel vor der Abnahme")
'Prüfen ob Vorlage-Datei geöffnet
For Each objWbArchiv In Application.Workbooks
If LCase(objWbArchiv.FullName) = LCase(strFileArchiv) Then Exit For
Next
If objWbArchiv Is Nothing Then
Set objWbArchiv = Workbooks.Open(strFileArchiv, ReadOnly:=True)
Else
MsgBox "Die Vorlagedatei ist geöffnet. Bitte die Datei schließen und das Makro neu starten! _
_
", , _
"Makro: copyAndDelete"
GoTo ErrExit
End If
'Ziel-Tabellenname in Vorlagedatei'                                   - ggf. Anpassen!
Set objShTgt = objWbArchiv.Sheets("Mängel vor der Abnahme")
'Spaltentitel-Zuordnungen
'Spalten im Blatt "Mängel vor der Abnahme" - in Erfassungsliste
arrSpaltenSource = Array("AF", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P" _
_
, "Q", "R", "S", "T", _
"U", "V", "W", "X", "Y", "Z", "AA", "AB", "AC", "AD", "AE")
'zugeordnete Spalten im Blatt "Mängel vor der Abnahme" - in Gesamtliste
arrSpaltenTarget = Array("C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", _
_
"Q", "R", "S", "T", _
"U", "V", "W", "X", "Y", "Z", "AA", "AB", "AC", "AD", "AE")
'Nummern der Spalten in ein Array einlesen
ReDim arrSpalten(0 To UBound(arrSpaltenSource), 1 To 2)
For lngNext = LBound(arrSpaltenSource) To UBound(arrSpaltenSource)
arrSpalten(lngNext, 1) = objShSrc.Range(arrSpaltenSource(lngNext) & "1").Column
arrSpalten(lngNext, 2) = objShSrc.Range(arrSpaltenTarget(lngNext) & "1").Column
Next
Erase arrSpaltenSource, arrSpaltenTarget
lngZeileTgt = 2
'"nein, Übernahme in Gesamtliste" in Spalte A suchen
Set rng = objShSrc.Range("A:A").Find(What:="nein, Übernahme in Gesamtliste", LookAt:=xlWhole,  _
_
_
LookIn:=xlValues, MatchCase:=False, After:=objShSrc.Range("A" & Rows.Count))
If Not rng Is Nothing Then
strFirst = rng.Address
Do
lngZeileTgt = lngZeileTgt + 1
strMsg = CStr(Val(strMsg) + 1) 'nein, Übernahme in Gesamtliste-Zeilen mitzählen
'Werte in Zeile übertragen
For lngNext = 0 To UBound(arrSpalten, 1)
With objShTgt
.Cells(lngZeileTgt, arrSpalten(lngNext, 2)).Value = _
objShSrc.Cells(rng.Row, arrSpalten(lngNext, 1)).Value
End With
Next
'Zeile(n) merken für späteres löschen
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
'neuen Dateinamen ermitteln
strFileArchiv = strPfad & "\" & Format(Date, "YYMMDD") & " Gesamtliste zur Mängelerfassung." _
_
'Prüfen, ob Datei schon vorhanden
varTest = Left(strFileArchiv, Len(strFileArchiv) - 1)
lngNext = 0
Do Until Dir(strFileArchiv & "*") = ""
lngNext = lngNext + 1
strFileArchiv = varTest & Format(lngNext, "00") & "."
Loop
strFileArchiv = Left(strFileArchiv, Len(strFileArchiv) - 1)
objWbArchiv.SaveAs Filename:=strFileArchiv, FileFormat:=objWbArchiv.FileFormat
objShSrc.Unprotect Password:="01234++"
rngCopy.Delete
objShSrc.Protect Password:="01234++"
objWbMaster.Save
MsgBox "Es wurden " & strMsg & " Datensätze übertragen!", vbInformation, "Hinweis"
Else
objWbArchiv.Close savechanges:=False
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
Erase arrSpalten
End Sub
'hier erfolgt die Prüfung nach ggf. vergessenen Zellen
Function fncTesten() As Boolean
Dim zeile As Long
Dim i As Integer
Dim strausgabe As String
Dim wks As Worksheet
Dim check As Boolean
Dim spaltenA1()
Dim spalten()
Dim spaltennamen()
Dim spaltenausgabe()
Set wks = ActiveWorkbook.Worksheets("Mängel vor der Abnahme")
'Prüfen, ob Autofilter gesetz
With wks
If .AutoFilterMode = True Then
If .FilterMode = True Then .ShowAllData
End If
End With
'im Blatt "Mängel vor der Abnahme" zu überprüfende Spalten, ob Zelle ausgefüllt
spaltenA1() = Array("C", "F", "G", "H", "I", "J", "L", "M", "N", "T", "W")
ReDim spalten(LBound(spaltenA1) To UBound(spaltenA1))
ReDim spaltennamen(LBound(spaltenA1) To UBound(spaltenA1))
ReDim spaltenausgabe(LBound(spaltenA1) To UBound(spaltenA1))
For i = 0 To UBound(spaltenA1)
spalten(i) = wks.Range(spaltenA1(i) & "1").Column 'Nummern der zu überprüfenden Spalten
spaltennamen(i) = "In der Spalte " & wks.Cells(2, spalten(i)).Text & " (" & spaltenA1(i) & " _
_
)"
Next
With wks
'Prüfen, ob in Zeilen mit "nein, Übernahme in Gesamtliste" in Spalte A alle zu prüfenden   _
_
Spalten ausgefüllt sind
For zeile = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
If LCase(.Cells(zeile, 1).Value) = "nein, Übernahme in Gesamtliste" Then
'zu prüfende Spalten abarbeiten
For i = 0 To UBound(spalten())
'Prüfen, ob leer oder = ""
If IsEmpty(Cells(zeile, spalten(i))) Or Cells(zeile, spalten(i)).Value = ""   _
_
Then
If spaltenausgabe(i) = "" Then
spaltenausgabe(i) = "    " & zeile
Else
spaltenausgabe(i) = spaltenausgabe(i) & ",   " & zeile
End If
check = True
End If
Next i
End If
Next zeile
End With
If check = True Then
'Ausgabetext für Meldung zusammenstellen
strausgabe = "Geprüfte Spalten:" & vbLf
For i = 0 To UBound(spaltenA1)
If i = UBound(spaltenA1) Then
strausgabe = strausgabe & "und (" & spaltenA1(i) & ")" & vbLf & vbLf & _
"Fehlerhaft ausgefüllte Zellen: " & vbLf & vbLf
Else
strausgabe = strausgabe & "(" & spaltenA1(i) & "), "
End If
Next
'Spalten mit fehlern anfügen
For i = 0 To UBound(spalten())
If spaltenausgabe(i)  "" Then
spaltenausgabe(i) = spaltennamen(i) & " in den Zeilen: " & vbLf & spaltenausgabe(i)
strausgabe = strausgabe & spaltenausgabe(i) & vbCrLf
End If
Next i
MsgBox strausgabe & vbLf & vbLf & "Daten werden jetzt kopiert", _
vbOKOnly, "Prüfen ""nein, Übernahme in Gesamtliste""-Zeilen"
fncTesten = False
Else
'Ausgabetext für Meldung zusammenstellen
strausgabe = "Es konnten keine leeren Zellen in den Spalten "
For i = 0 To UBound(spaltenA1)
If i = UBound(spaltenA1) Then
strausgabe = strausgabe & "und " & wks.Cells(2, spalten(i)).Text & " (" & spaltenA1(i)   _
_
_
& ") gefunden werden!"
Else
strausgabe = strausgabe & wks.Cells(2, spalten(i)).Text & " (" & spaltenA1(i) & "), "
End If
Next
MsgBox strausgabe & vbLf & vbLf & "Daten werden jetzt kopiert", _
vbQuestion + vbOKOnly, "Prüfen ""nein, Übernahme in Gesamtliste""-Zeilen"
fncTesten = True
End If
End Function