Sheet nach Jahr löschen | Herbers Excel-Forum

Option Explicit Sub cp_wbk() Application.ScreenUpdating = False 'ActiveSheet.Unprotect Password:="Test" 'Dim SaveAs As String Dim aSh, nSh As String nSh = ActiveSheet.[G1] aSh = ActiveSheet.Name Sheets(aSh).Copy after:=Sheets(Sheets.Count) ActiveSheet.Name = nSh Sheets(aSh).Shapes("Button 1").Delete Sheets(nSh).ScrollArea = "$A$1:$O$52" Application.DisplayAlerts = False 'Speichern unter aus ActiveWorkbook.SaveAs Filename:="Stundenaufzeichnung" & " " & Sheets(nSh).Range("B3") & " " & _ _ Format(Range("G1"), "YYYY") & ".xls" Application.DisplayAlerts = True 'Speichern unter ein Sheets(aSh).Protect Password:="Test" End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub heinz() Dim objSh As Worksheet On Error GoTo ErrExit Application.DisplayAlerts = False For Each objSh In ThisWorkbook.Worksheets If IsNumeric(objSh.Range("G1")) And objSh.Range("G1") <= Year(Date) Then If ThisWorkbook.Sheets.Count > 1 Then objSh.Delete End If Next ErrExit: Application.DisplayAlerts = True End Sub Gruß Sepp

'Neuer Sheet wir alter Sheet & Speichern Sub cp_wbk() Application.ScreenUpdating = False ActiveSheet.Unprotect Password:="woody-6962" Dim aSh, nSh As String nSh = ActiveSheet.[G1] aSh = ActiveSheet.Name Sheets(aSh).Copy after:=Sheets(Sheets.Count) ActiveSheet.Name = nSh Sheets(aSh).Shapes("Button 1").Delete Sheets(nSh).ScrollArea = "$A$1:$O$52" Application.DisplayAlerts = False 'Speichern unter aus ActiveWorkbook.SaveAs Filename:="Stundenaufzeichnung" & " " & Sheets(nSh).Range("B3") & " " & _ Format(Range("G1"), "YYYY") & ".xls" Call heinz Application.DisplayAlerts = True 'Speichern unter ein Sheets(aSh).Protect Password:="woody-6962" End Sub

Sub WochenendeWeg(monat As Boolean) Application.ScreenUpdating = False Application.EnableEvents = False 'Wenn Datum grösser als Heute If Range("H1") > Date Then MsgBox "Bitte warten sie bis zum - " & Format(Range("H1") + 1, "DD. MMMM YYYY") 'Application.ScreenUpdating = True End 'Exit Sub End If '-------Monat um 1 Hochzählen---------- ActiveSheet.Unprotect Password:="woody-6962" Application.ScreenUpdating = False 'In G1 steht jetzt eine Formel, die nicht mehr geändert werden muss, 'daher wird nur noch F1 geändert. If monat = False Then If MsgBox("Wollen Sie ein neues Monat erstellen ?", vbQuestion + vbYesNo, _ " Nachfrage Neues Monat erstellen !") = vbNo Then Exit Sub Range("F1") = DateAdd("m", 1, Range("F1")) 'Von J36 werden die Daten in J5 eingetragen.Im neuen Blatt Range("J5") = Range("J36").Value 'Urlaub.Bildungsurlaub + Pflegefreistellung Range("M40:M42") = Range("O40:O42").Value Call cp_wbk End If

Sub heinz() Dim objSh As Worksheet On Error GoTo ErrExit Application.DisplayAlerts = False For Each objSh In ThisWorkbook.Worksheets If IsDate(objSh.Range("G1")) And Year(objSh.Range("G1")) <= Year(Date) Then If ThisWorkbook.Sheets.Count > 1 Then objSh.Delete End If Next ErrExit: Application.DisplayAlerts = True End Sub Gruß Sepp

Sub heinz() Dim objSh As Worksheet On Error GoTo ErrExit Application.DisplayAlerts = False For Each objSh In ThisWorkbook.Worksheets If IsDate(objSh.Range("F1")) And Year(objSh.Range("F1")) < Year(Date) Then If ThisWorkbook.Sheets.Count > 1 Then objSh.Delete End If Next ErrExit: Application.DisplayAlerts = True End Sub Gruß Sepp

Hallo Josef
Mit diesen Code wird ein Sheet kopiert.
Zwischenfrage habe in S3 das Jahr Zb.2009
Könnte man wenn in S2 =S3-1 = 2008
mit diesen Arbeiten.
Also Wenn in Sheet F1=S2 dann Sheet löschen ?

Sub cp_wbk()
Application.ScreenUpdating = False
ActiveSheet.Unprotect Password:="woody-6962"
Dim aSh, nSh As String
nSh = ActiveSheet.[F1]
aSh = ActiveSheet.Name
Sheets(aSh).Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = nSh
Sheets(aSh).Shapes("Button 1").Delete
'Sheets(nSh).ScrollArea = "$A$1:$O$52"
Application.DisplayAlerts = False 'Speichern unter aus
ActiveWorkbook.SaveAs Filename:="Stundenaufzeichnung" & " " & Sheets(nSh).Range("B3") & " " &  _
Format(Range("G1"), "YYYY") & ".xls"
Application.DisplayAlerts = True 'Speichern unter ein
'Sheets(aSh).Protect Password:="woody-6962"
End Sub

Hier wird um ein Monat hochgezählt.

Sub WochenendeWeg(monat As Boolean)
Application.ScreenUpdating = False
Application.EnableEvents = False
'Wenn Datum grösser als Heute
If Range("H1") > Date Then
MsgBox "Bitte warten sie bis zum -  " & Format(Range("H1") + 1, "DD. MMMM YYYY")
'Application.ScreenUpdating = True
End
'Exit Sub
End If
'-------Monat um 1 Hochzählen----------
ActiveSheet.Unprotect Password:="woody-6962"
Application.ScreenUpdating = False
'In G1 steht jetzt eine Formel, die nicht mehr geändert werden muss,
'daher wird nur noch F1 geändert.
If monat = False Then
If MsgBox("Wollen Sie ein neues Monat erstellen ?", vbQuestion + vbYesNo, _
" Nachfrage Neues Monat erstellen !") = vbNo Then Exit Sub
Range("F1") = DateAdd("m", 1, Range("F1"))
'Von J36 werden die Daten in J5 eingetragen.Im neuen Blatt
Range("J5") = Range("J36").Value
'Urlaub.Bildungsurlaub + Pflegefreistellung
Range("M40:M42") = Range("O40:O42").Value
Call cp_wbk
End If
'Application.EnableEvents = False
'Blattname neu bestimmen
ActiveSheet.Name = Range("G1")
'ActiveSheet.Unprotect Password:="woody-6962"
Dim datStart As Date, datEnd As Date
Dim lDay As Long
Dim iRow As Integer, lngStart As Long, lngCol As Long
datStart = Range("F1").Value ' in der Zelle M3 befindet sich das Anfangsdatum
datEnd = Range("H1").Value   ' in der Zelle H1 befindet sich das Enddatum
iRow = 6  'Hiermit wird gesagt, dass in Zeile 6 angefangen werden soll
lngStart = iRow
Range("A6:A35").EntireRow.ClearContents ' Franz Zeile geändert. Statt löschen der Zeilen  _
werden nur Inhalte gelöscht
Range("C6:F35").EntireRow.ClearContents ' Statt löschen der Zeilen werden nur Inhalte gelö _
scht
Range("L6:L35").EntireRow.ClearContents ' Statt löschen der Zeilen werden nur Inhalte gelö _
scht
Range("A6:A35").EntireRow.Interior.ColorIndex = xlColorIndexNone 'Franz entfernt Farbe aus  _
Zellbereich
Range("A6:O35").Font.Bold = False 'Schriftart Fett zurücksetzen
Range("A6:A35").NumberFormatLocal = "TT.MM.JJJJ"
Range("B6:B35").NumberFormatLocal = "TTT"
Range("A6:O35").Locked = True  'Zellschutz aufheben
Gruß
Heinz

Sub heinz(ByVal intYear As Integer) Dim objSh As Worksheet On Error GoTo ErrExit Application.DisplayAlerts = False For Each objSh In ThisWorkbook.Worksheets If IsDate(objSh.Range("G1")) And Year(objSh.Range("G1")) < intYear Then If ThisWorkbook.Sheets.Count > 1 Then objSh.Delete End If Next ErrExit: Application.DisplayAlerts = True End Sub Gruß Sepp

Sub cp_wbk() Application.DisplayAlerts = False 'Application.ScreenUpdating = False ActiveSheet.Unprotect Password:="woody-6962" Dim aSh, nSh As String nSh = ActiveSheet.[F1] aSh = ActiveSheet.Name Sheets(aSh).Copy after:=Sheets(Sheets.Count) ActiveSheet.Name = nSh 'Sheets(aSh).Shapes("Button 1").Delete 'Sheets(nSh).ScrollArea = "$A$1:$O$52" 'Application.DisplayAlerts = False 'Speichern unter aus ActiveWorkbook.SaveAs Filename:="Stundenaufzeichnung" & " " & Sheets(nSh).Range("B3") & " " & _ Format(Range("G1"), "YYYY") & ".xls" 'Application.DisplayAlerts = True 'Speichern unter ein 'Sheets(aSh).Protect Password:="woody-6962" End Sub

Option Explicit Sub cp_wbk() Application.ScreenUpdating = False ActiveSheet.Unprotect Password:="woody-6962" Dim aSh, nSh As String nSh = ActiveSheet.[G1] aSh = ActiveSheet.Name Sheets(aSh).Copy after:=Sheets(Sheets.Count) ActiveSheet.Name = nSh Sheets(aSh).Shapes("Button 1").Delete Sheets(nSh).ScrollArea = "$A$1:$O$52" 'Application.DisplayAlerts = False 'Speichern unter aus ActiveWorkbook.SaveAs Filename:="Stundenaufzeichnung" & " " & Sheets(nSh).Range("B3") & " " & _ Format(Range("G1"), "YYYY") & ".xls" 'Application.DisplayAlerts = True 'Speichern unter ein Sheets(aSh).Protect Password:="woody-6962" End Sub

Sub heinz(jahr As Integer) Application.DisplayAlerts = False Dim objSh As Worksheet MsgBox "Es wird eine neue Stundenaufzeichnung für das Jahr " & jahr & " erstellt" On Error GoTo ErrExit For Each objSh In ThisWorkbook.Worksheets If IsDate(objSh.Range("B1")) And Year(objSh.Range("B1")) < jahr Then If ThisWorkbook.Sheets.Count > 1 Then objSh.Delete End If Next ErrExit: Application.DisplayAlerts = True End Sub

Beliebteste Forumthreads (12 Monate)

Sheet nach Jahr löschen | Herbers Excel-Forum

20 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread