Einzelnen Beitrag anzeigen
Alt 19.10.2017, 16:17   #1
knuepel
Neuer Benutzer
Neuer Benutzer
Standard wenn Inhalt Zelle X dann bestimmte Zellen kopieren (Werte) und Inhalt löschen

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:
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.

Code:

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
'##### ENDE EINSTELLUNGEN #####

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

Geändert von knuepel (19.10.2017 um 16:26 Uhr).
knuepel ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten