knuefi
Goto Top

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


  • 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
werden soll.

  • 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

Content-Key: 352231

Url: https://administrator.de/contentid/352231

Ausgedruckt am: 19.03.2024 um 09:03 Uhr

Mitglied: 134464
134464 20.10.2017 aktualisiert um 10:22:02 Uhr
Goto Top
Mitglied: Knuefi
Knuefi 20.10.2017 um 17:20:39 Uhr
Goto Top
Habe es selber hin bekommen face-smile, vielleicht sollte ich mein Beruf wechseln.