Excel 2013 - wenn Inhalt Zelle X dann bestimmte Ze
19.10.2017 19:50:52
knüfi
ich hoffe mir kann jemand weiterhelfen. Ich habe eine Excel Datei mit zwei Tabellen Blätter
Tabelle1
Tabelle2
Zudem gibt es eine extra Excel Datei mit den Namen Archiv
werden soll.
Nun zu meine Bitte:
leider haben sich unseren Arbeitsschritte geändert und das Makro müsste angepasst werden, dafür fehlt mir leider das nötige Fachwissen
Das Makro müsste bei Eingabe "erledigt" in der Tabelle2 Zelle AB die entsprechende Spalte die Werte (nicht Formeln) der Zellen A bis AE kopieren und im Archiv abspeichern.
Anschließend sollen nur in der Tabelle1 die einsprechende Spalte die Inhalte in den Zellen M bis O gelöscht werden und in der Tabelle2 die einsprechende Spalte die Inhalte in den S bis AB.
Option Explicit
Private Const cstrFileArchive As String = "D:UsersDesktopTestArchiv Artikel_Archiv.xls" 'Pfad und Name der Archivdatei
Private Const cstrMasterTabelle As String = "Tabelle2" 'Name Tabellenblatt in 'Master'
Private Const cstrArchiveTabelle As String = "Tabelle1" 'Name Tabellenblatt in 'Archiv'
Private Const cstrArchiveWritePW As String = "strenggeheim" 'Schreibschutz-Passwort der Archiv-Datei
Private Const cstrMasterTabPW As String = "" 'Passwort für Master-Tabelle
Private Const cstrArchiveTabPW As String = "" 'Passwort für Archiv-Tabelle
Sub copyAndDelete()
Dim objWbMaster As Workbook, objWbArchive As Workbook
Dim objShSrc As Worksheet, objShTgt As Worksheet
Dim rng As Range, rngCopy As Range
Dim strFirst As String
Dim lngNext As Long, lngC As Long
Dim blnOpen As Boolean
On Error GoTo ErrExit
Set objWbMaster = ThisWorkbook
Set objShSrc = objWbMaster.Sheets(cstrMasterTabelle)
With objShSrc
.Unprotect cstrMasterTabPW
Set rng = .Range("AB:AB").Find(What:="erledigt", LookAt:=xlWhole, _
LookIn:=xlValues, MatchCase:=False, After:=.Range("AB" & .Rows.Count))
End With
If Not rng Is Nothing Then
strFirst = rng.Address
Do
lngC = lngC + 1
If rngCopy Is Nothing Then
Set rngCopy = rng.EntireRow
Else
Set rngCopy = Union(rngCopy, rng.EntireRow)
End If
Set rng = objShSrc.Range("AB:AB").FindNext(rng)
Loop While Not rng Is Nothing And strFirst rng.Address
End If
If Not rngCopy Is Nothing Then
For Each objWbArchive In Application.Workbooks
If objWbArchive.FullName = cstrFileArchive Then Exit For
Next
If objWbArchive Is Nothing Then
Set objWbArchive = Workbooks.Open(cstrFileArchive, WriteResPassword:=cstrArchiveWritePW)
blnOpen = True
End If
Set objShTgt = objWbArchive.Sheets(cstrArchiveTabelle)
With objShTgt
.Unprotect cstrArchiveTabPW
lngNext = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
rngCopy.Copy .Cells(lngNext, 1)
.Cells(lngNext, 40).Resize(lngC, 1) = Now
.Cells(lngNext, 41).Resize(lngC, 1) = Environ("USERNAME")
.Protect cstrArchiveTabPW
End With
If blnOpen Then
objWbArchive.Close True
Else
objWbArchive.Save
End If
rngCopy.Delete
objShSrc.Protect cstrMasterTabPW
objWbMaster.Save
MsgBox "Es wurden " & CStr(lngC) & " 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 objWbArchive = Nothing
Set rng = Nothing
Set rngCopy = Nothing
End Sub