AW: Makro speichern und löschen
06.11.2016 06:22:57
fcs
Hallo Ralf,
hier ein Beispiel wie man es lösen kann.
Falls du übergeordnete Blätter hast, in denen Salden/Summenwerte berechnet werden, dann musst du diese immer vor den untergeordneten zurücksetzen, da sonnst die Summenberechnungen falsch werden.
Gruß
Franz
Sub Tabellen_zuruecksetzen()
Dim wkb As Workbook
Dim wks As Worksheet, intS As Integer
Dim StatusCalc As Long
Dim Zeile As Long
If MsgBox("Arbeitsmappe zurücksetzen?", _
vbQuestion + vbOKCancel + vbDefaultButton2, _
"Abrechnung Kegeln") = vbCancel Then Exit Sub
Set wkb = ActiveWorkbook
With Application
'Alles neu berechnen
.Calculate
'Makrobremsen lösen
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
' .EnableEvents = False 'nur erforderlich, wenn in der Datei Ereignismakros verwendet _
werden.
End With
'Werte im Blatt "Kegeltermin" neu setzen
Set wks = wkb.Worksheets("Kegeltermin")
With wks
'Neues Datum (nächster Tag) in C2 eintragen
.Cells(2, 3).Value = .Cells(2, 3).Value + 1
'oder
.Cells(2, 3).Value = Date + 1
'usw.
End With
For intS = 1 To wkb.Worksheets.Count
Set wks = wkb.Worksheets(intS)
With wks
Select Case .Name
Case "Tabelle1", "TabelleXYZ"
'für alle Tabellenblätter, die identisch wie "Tabelle1" aufgebaut sind
Call Reset_wks_Typ1(wks)
Case Else
'do nothing
End Select
End With
Next
With Application
'Alles neu berechnen
.Calculate
'Makrobremsen zurücksetzen
.ScreenUpdating = True
.Calculation = StatusCalc
' .EnableEvents = True
End With
End Sub
Sub Reset_wks_Typ1(wks As Worksheet)
Dim Zeile As Long
'für alle Tabellenblätter, die identisch wie "Tabelle1" ("Kassenbeleg")aufgebaut sind
With wks
'Clubkasse Kontostand neu nach alt übertragen
.Range("K6").Value = .Range("K15").Value
'Sondereinnahmen und Ausgaben auf 0 stzen
.Range("K10:K11").Value = 0
'Inhalte Bemerkungen löschen
.Range("J18:K30").ClearContents
'Saldo-Werte aus Spalte H (8) nach C (3) übertragen
For Zeile = 5 To 29 Step 2
.Cells(Zeile, 3).Value = .Cells(Zeile, 8).Value
Next Zeile
'Eingaben in Spalte D löschen
.Range("D5:D30").ClearContents
'Eingaben in Spalten E bis G löschen
.Range("E5:G30").ClearContents
End With
End Sub