Makro Löschen

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
ActiveSheet.Unprotect
If Intersect(Target, Range("A6:A42")) Is Nothing Then Exit Sub
Application.EnableEvents = False
Set MeinBereich = Cells(Target.Row, 1)
UserForm3.Show
Application.EnableEvents = True
Cancel = True
ActiveSheet.Protect
End Sub

Makro (Im Modul"
Option Explicit
Sub cp_wbk()
Dim MyShape As Shape, strPfaduDatei As String
Dim Shape2 As Shape
Application.ScreenUpdating = False
ActiveSheet.Unprotect
With ThisWorkbook
strPfaduDatei = .Path & "\" & .Sheets(1).Range("B3") & _
" " & Format(.Sheets(1).Range("A6"), "mmmm YYYY")
ActiveSheet.Cells(1, 1).Activate
.Sheets(1).Copy
End With
For Each MyShape In ActiveSheet.Shapes
If MyShape.AlternativeText "" Then MyShape.Delete
Next
ActiveWorkbook.SaveAs strPfaduDatei
ActiveWorkbook.Close
Range("O47:O49").Copy
Range("M47").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = True
ActiveSheet.Cells(1, 1).Activate
ActiveSheet.Protect
End Sub
Sub WochenendeWeg()
ActiveSheet.Unprotect
Application.ScreenUpdating = False
If MsgBox("Wollen Sie ein neues Monat erstellen ?", vbQuestion + vbYesNo, _
" Nachfrage Neues Monat erstellen !") = vbNo Then Exit Sub
'*******************************************************************************************
'Blattname neu bestimmen
ActiveSheet.Name = Range("G1")
Dim datStart As Date, datEnd As Date
Dim lDay As Long
Dim iRow As Integer
Dim Text As String ''
Dim a, datum
Dim quellwks As Worksheet
Dim zielwks As Worksheet
Set quellwks = Sheets(1)
datum = Date
a = Range("H1").Value + 1
If Date MsgBox "Sie dürfen erst ab " & a & " ein neues Blatt einfügen.", vbOKOnly + vbQuestion: Exit Sub
End If '################################################################################
Call cp_wbk
ActiveSheet.Unprotect
'Application.ScreenUpdating = True
'-------Monat um 1 Hochzählen----------
'In G1 steht jetzt eine Formel, die nicht mehr geändert werden muss,
'daher wird nur noch F1 geändert.
'++++++++
'################################################################################
'End If
Range("F1") = DateAdd("m", 1, Range("F1"))
datStart = Range("F1").Value ' in der Zelle F1 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
'Bevor die Daten des neuen Monats eingetragen werden, alte Daten löschen.
'Anschließend Zahlenformate in den Spalten A und B wiederherstellen
'Range("A" & iRow & ":A100").EntireRow.Delete
Range("A6:A42").EntireRow.ClearContents 'Inhalte löschen
Range("A6:A42").EntireRow.Interior.ColorIndex = xlColorIndexNone 'entfernt Farbe aus Zellbereich
Range("A6:A42").NumberFormatLocal = "TT.MM.JJJJ"
Range("B6:B42").NumberFormatLocal = "TTT"
'********************************************************************************
For lDay = datStart To datEnd
Cells(iRow, 1) = lDay
Cells(iRow, 2) = lDay
iRow = iRow + 1
iRow = iRow - (Weekday(lDay, 2) = 7)
Next
Dim sp#, Such$, LR%, TB1, i#, m%, Z1%
'anpassen ******
Set TB1 = Sheets(ActiveSheet.Name)
sp = 2 'Spalte mit den Wochentagen
Such = "So"
Z1 = 6 'erste Zeile mit Daten
'*******
Dim M1%
LR = TB1.Cells(Rows.Count, sp).End(xlUp).Row 'letzte Zeile der Spalte
For i = LR To Z1 Step -1
If Cells(i, sp).Text = Such Then
' Rows(i + 1).Insert 'Zeile zu Kommentar gemacht, da Leerzeile zwischen Wochen schon vorhanden
If i m = i - Z1 + 1
Else
m = 7
End If
Cells(i + 1, sp + 5).FormulaR1C1 = "=Sum(R[-" & m & "]C:R[-1]C)"
Cells(i + 1, sp + 6).FormulaR1C1 = "=Sum(R[-" & m & "]C:R[-1]C)"
Cells(i + 1, sp + 7).FormulaR1C1 = "=Sum(R[-" & m & "]C:R[-1]C)"
Cells(i + 1, sp + 8).FormulaR1C1 = "=Sum(R[-" & m & "]C:R[-1]C)"
Range(Cells(i + 1, 1), Cells(i + 1, 15)).Interior.ColorIndex = 34
End If
Next
Do
M1 = M1 + 1
Loop Until Range("A42").End(xlUp).Offset(-M1, 0) = ""
Cells(Range("A42").End(xlUp).Offset(1, 0).Row, sp + 5).FormulaR1C1 = "=Sum(R[-" & M1 & "]C:R[-1]C)"
Cells(Range("A42").End(xlUp).Offset(1, 0).Row, sp + 6).FormulaR1C1 = "=Sum(R[-" & M1 & "]C:R[-1]C)"
Cells(Range("A42").End(xlUp).Offset(1, 0).Row, sp + 7).FormulaR1C1 = "=Sum(R[-" & M1 & "]C:R[-1]C)"
Cells(Range("A42").End(xlUp).Offset(1, 0).Row, sp + 8).FormulaR1C1 = "=Sum(R[-" & M1 & "]C:R[-1]C)"
Range(Range("A42").End(xlUp).Offset(1, 0), _
Range("A42").End(xlUp).Offset(1, 14)).Interior.ColorIndex = 34
Fehler:
If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description