Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Sheet nach Jahr löschen | Herbers Excel-Forum


Betrifft: Sheet nach Jahr löschen von: Heinz H
Geschrieben am: 18.01.2010 21:56:03

Hallo Ja Ja - Ich schon wieder

Komme immer wieder auf Sachen drauf,zum ändern

Habe das untere Makro das mir neue Sheet in einer Mappe erstellt, und speichert.

ZB. "Stundenaufzeichnung Test 2009" Hier sind alle Sheet die in G1 das Jahr zB.2009 haben.

Wenn nun ein Jahreswechsel in G1 erfolgt,wird die Mappe unter:
ZB. "Stundenaufzeichnung Test 2010" gespeichert.

Das funktioniert auch super.
Nur würden alle Sheet entfernt gehören die in G1 das Jahr 2009 haben.

Also in der Mappe zB. 2010 nur mit Sheet G1 2010.

Das bekomme ich leider nicht zuwege.
Darum BITTE ich Euch nochmals um Hilfe.

Gruß
Heinz

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

  

Betrifft: AW: Sheet nach Jahr löschen von: Josef Ehrensberger
Geschrieben am: 18.01.2010 23:50:27

Hallo Heinz,

vielleicht so.

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



  

Betrifft: AW: Sheet nach Jahr löschen von: Heinz H
Geschrieben am: 19.01.2010 07:05:24

Guten morgen Josef

Sorry das ich einigen hier im Forum schon am Ars.. gehe.

Danke für deinen Code.

Nur kann ich ihn nicht Starten.
Habe schon einige Variationen durchgespielt,kein Erfolg.

Gruß
Heinz

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


'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



  

Betrifft: AW: Sheet nach Jahr löschen von: Josef Ehrensberger
Geschrieben am: 19.01.2010 07:20:12

Hallo Heinz,

ich dachte in G1 steht nur die Jahreszahl.

Mit Datum in G1 geht's so.

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



  

Betrifft: AW: Sheet nach Jahr löschen von: Heinz H
Geschrieben am: 19.01.2010 07:38:02

Guten morgen, Josef

Welch Glücksgefühl so früh am morgen.

Nochmals recht herzlichen DANK !!

Hoffe für alle im Forum,das ich jetzt einige Zeit Ruhe geben kann.

Gruß
(Der Nervige) Heinz


  

Betrifft: AW: Sheet nach Jahr löschen von: Heinz H
Geschrieben am: 19.01.2010 09:23:48

Hallo Josef

Muß mich leider doch noch einmal melden.

Habe beim genaueren Testen einen Fehler gefunden.
Es werden immer alle Sheet gelöscht,bis auf den ersten & den neu erstellten.
Auch wenn sie das selbe Jahr haben.

Hättest du bitte nochmals eine Lösung für mich.

Gruß
Heinz



https://www.herber.de/bbs/user/67305.xls


  

Betrifft: AW: Sheet nach Jahr löschen von: Josef Ehrensberger
Geschrieben am: 19.01.2010 09:36:50

Hallo heinz,

es muß <, statt < = heißen.

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



  

Betrifft: AW: Sheet nach Jahr löschen von: Heinz H
Geschrieben am: 19.01.2010 10:04:08

Hallo Josef

Leider der selbe Effekt. Sobald ich auf Button "Neuen Monat anlegen" wird der alte Sheet gelöscht.

Gruß
Heinz


  

Betrifft: AW: Sheet nach Jahr löschen von: Josef Ehrensberger
Geschrieben am: 19.01.2010 10:19:08

Hallo Heinz,

also ich habe dich so verstanden, das alle Blätter in denen das Jahr in F1 kleiner
als das aktuelle ist, gelöscht werden sollen.

Wenn dem nicht si sein sollte, dann erkläre, welche Blätter gelocht werden sollen.


Gruß Sepp



  

Betrifft: AW: Sheet nach Jahr löschen von: Heinz H
Geschrieben am: 19.01.2010 10:25:35

Hallo Josef

Genau so sollte es sein.

Zb. es sind Sheet in "F1" 01.03.2008 - 1.4.2008 usw...

Jetzt kommt ein neues Monat "F1" 1.1.2009 dann alle Sheet löschen mit "F1" 2008

Gruß
Heinz


  

Betrifft: AW: Sheet nach Jahr löschen von: Josef Ehrensberger
Geschrieben am: 19.01.2010 11:00:34

Hallo Heinz,

und in welchem Tabellenblatt wird das neue Datum eingegeben?


Gruß Sepp



  

Betrifft: AW: Sheet nach Jahr löschen von: Heinz H
Geschrieben am: 19.01.2010 11:10:10

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



  

Betrifft: AW: Sheet nach Jahr löschen von: Heinz H
Geschrieben am: 19.01.2010 11:30:20

Hallo Josef

Könnte man auch nicht: Wenn F1 (Jahr) kleiner als heute; Sheet löschen ?

Gruß
Heinz


  

Betrifft: AW: Sheet nach Jahr löschen von: Josef Ehrensberger
Geschrieben am: 19.01.2010 11:34:50

Hallo Heinz,

sehe zwar nirgends die Variable S3, aber egal.

Übetrgib der Prozedur einfach das Jahr als Parameter,
alle Tabellen in denen das Jahr in G1 kleiner ist als das übergebene Jahr,
werden gelöscht.


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



  

Betrifft: AW: Sheet nach Jahr löschen von: Heinz H
Geschrieben am: 19.01.2010 12:14:24

Hallo Josef

Recht herzlichen DANK für deine Großzügige Hilfe.

Leider funktioniert keine Variante. Wieso ?? Ich weiss es leider nicht.
Muss mal bei Zeit irgend eine andere Variante ausdenken.

Muß jetzt mittagessen und dann ab in die Arbeit.

Nochmals recht herzlichen Dank für Deine Großartige Bemühungen,mir zu helfen.
Gruß
Heinz


  

Betrifft: AW: Letzter Versuch von: Heinz H
Geschrieben am: 19.01.2010 16:58:03

Hallo Josef

Würdest du bitte einen letzten Versuch starten.

Im unteren Makro wird das Aktive (nSh) kopiert und zum inaktiven (aSh) gemacht.
Vielleicht funktioniert es wnn man Sinngemäß sagt:
Ist das inaktive Sheet(aSh) G1 kleiner als heute (Jahr) dann delete.
Bitte - Heinz


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



  

Betrifft: AW: Letzter Versuch von: Josef Ehrensberger
Geschrieben am: 19.01.2010 17:02:47

Hallo Heinz,

na das solltest du mittlerweile aber auch selbst hinbringen.


If Year(Sheets(aSh).Range("G1")) < Year(Date) then
  Sheets(aSh).Delete
End If

Gruß Sepp



  

Betrifft: AW: Letzter Versuch - Leider Leider owT von: Heinz H
Geschrieben am: 19.01.2010 19:13:00




  

Betrifft: AW:Mappe für jedes Jahr von: Heinz H
Geschrieben am: 20.01.2010 09:25:31

Guten morgen im Forum

Konnte sehr schlecht schlafen.Mir lässt das einfach keine Ruhe.

Andere Idee: Im unteren Makro wird ja die Mappe unter dem Jahr von G1 gespeichert.
Könnte man die Mappe nicht schliessen sobald sich das Speicherdatum
Format(Range("G1"), "YYYY") ändert,un der letzte Sheet von Workbook alt in die Workbook neu mitkopiert wird.
Oder nach dem Worksheet mit Namen erstellt wurde alle bis auf den letzten Sheets gelöscht werden.(Ist immer (1.12. YYYY) in G1)

Ich würde einfach eine Mappe für jedes Jahr brauchen.
Ich bin echt schon am verzeifeln

Gruß
Heinz

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



  

Betrifft: bin echt schon am verzeifeln-wir auch :-) von: robert
Geschrieben am: 20.01.2010 13:00:43

hi,

eines frage ich mich:

warum gehst du mit deinen kenntnissen so ein projekt an ?

wenn man deine beiträge ansieht, kommt immer wieder diese zeiterfassung.....

das was du willst, ist keine hilfe mehr, sondern grenzt schon fast
an auftragsprogrammierung :-)

ich stelle die frage wieder auf offen, da ich dir leider nicht helfen kann-sorry

gruß
robert


  

Betrifft: AW: bin echt schon am verzeifeln-wir auch :-) von: Heinz H
Geschrieben am: 24.01.2010 10:54:56

Hallo Josef

Jetzt hab ich es hingebracht.


Ich danke dir nochmals recht herzlich.

Gruß
Heinz

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
'Formel in B1 eingeben
   Range("B1") = Range("F1").Value
   If Month(Range("B1")) = 1 Then
   Call heinz(Year(Range("B1")))
   End If



Beiträge aus den Excel-Beispielen zum Thema "Sheet nach Jahr löschen"