AW: Daten in Tabellenblatt 2 ablegen und archivieren
26.06.2010 13:44:35
fcs
Moin Jasper,
mit folgenden Anpassungen und Ergänzungen werden vor dem löschen die Daten ins Archiv übertragen.
Vor bzw. während des Übertragens werden mehrere Prüfungen durchgeführt. Je nach Ergebnis und getroffener Auswahl werden die Daten im Eingabeblatt dann nicht gelöscht.
Gruß
Franz
Sub loeschen()
Dim sh1 As Object
Dim rng1, rng2 As Range
If Archivieren = False Then GoTo Beenden
Set sh1 = ThisWorkbook.Sheets("Eingaben")
Set rng1 = sh1.Range("b2:b6"): rng1.ClearContents
Set rng2 = sh1.Range("B1"): rng2.ClearContents
Beenden:
End Sub
Function Archivieren() As Boolean
Dim Zeile As Long
Dim wksEingabe As Worksheet, wksArchiv As Worksheet
Dim Zelle As Range, SpalteA As Long, ZeileA As Long
Dim sName As String, vDatum As Variant
Archivieren = True
Set wksArchiv = Worksheets("Archiv")
Set wksEingabe = Worksheets("Eingaben")
vDatum = wksEingabe.Cells(1, 2)
'Datum im Archiv suchen
With wksArchiv
For SpalteA = 2 To .Cells(1, .Columns.Count).End(xlToLeft).Column
If .Cells(1, SpalteA) = vDatum Then Exit For
Next
If SpalteA > .Cells(1, .Columns.Count).End(xlToLeft).Column Then
MsgBox "Datum """ & vDatum & """ fehlt im Blatt ""Archiv"""
Archivieren = False
GoTo Beenden
End If
End With
If wksArchiv.Cells(wksArchiv.Rows.Count, SpalteA).End(xlUp).Row > 1 Then
If MsgBox("Im Archiv stehen für """ & vDatum & """ schon Daten" _
& vbNewLine & vbNewLine & "Daten überschreiben?", _
vbQuestion + vbYesNo + vbDefaultButton2, "Daten ins Archiv") = vbNo Then
Archivieren = False
GoTo Beenden
Else
'Für Tag vorhandenen Daten löschen
With wksArchiv
.Range(.Cells(2, SpalteA), _
.Cells(.Rows.Count, SpalteA).End(xlUp)).Clear
End With
End If
End If
'Daten ins Archiv übertragen
For Zeile = 2 To wksEingabe.Cells(wksEingabe.Rows.Count, 1).End(xlUp).Row
sName = wksEingabe.Cells(Zeile, 1)
Set Zelle = wksArchiv.Columns(1).Find(what:=sName, LookIn:=xlValues, _
lookat:=xlWhole)
If Zelle Is Nothing Then
If MsgBox("Name """ & sName & """ fehlt im Blatt """ & wksArchiv.Name & """" _
& vbNewLine & vbNewLine & "Namen in Liste ergänzen?", _
vbQuestion + vbYesNo, "Daten ins Archiv") = vbYes Then
'Neuen Namen einfügen
ZeileA = wksArchiv.Cells(wksArchiv.Rows.Count, 1).End(xlUp).Row + 1
wksArchiv.Cells(ZeileA, 1) = sName
wksEingabe.Cells(Zeile, 2).Copy wksArchiv.Cells(ZeileA, SpalteA)
Else
Archivieren = False
End If
Else
ZeileA = Zelle.Row
wksEingabe.Cells(Zeile, 2).Copy wksArchiv.Cells(ZeileA, SpalteA)
End If
Next
Beenden:
End Function