Wenn Inhalt Zelle X dann bestimmte Zellen
Hallo zusammen,
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
Nun zu meine Bitte:
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.
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
- Es werden in der Tabelle1 in den Zellen M bis O Werte (Datum, Uhrzeit, Text) eingetragen und diese werden mit einer Formel in der Tabelle2 in den Zelllen P bis R dargestellt.
- Anschließend wird in der Tabelle2 Zelle S das Wort/Wert "Bearbeitet" eingeben und dieses wird mit Hilfe einer Formel in der Tabelle1 in Zelle P dargestellt.
- Nach einigen weitern nicht relevanten Schritte wird in der Tabelle2 in Zelle AB das Wort"erledigt" ausgewählt. Dadurch weiß das unten aufgeführte Makro welche Zelle in der Tabelle2 bearbeitet
- Das Makro kopiert die ganze Spalte (inklusive Formeln), fügt User hinzu und speichert es in ein Archiv ab. Anschließend wird die ganze Spalte gelöscht.
Nun zu meine Bitte:
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.
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
End Sub
Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben
Content-ID: 352231
Url: https://administrator.de/contentid/352231
Ausgedruckt am: 22.11.2024 um 05:11 Uhr
2 Kommentare
Neuester Kommentar