Makro funktioniert nicht!
13.08.2003 14:52:52
Chris
ich habe mal wieder ein kleines Problem:
Ich habe ein Schreibgeschütztes Blatt. Hinter diesem Blatt ist ein Makro hinterlegt, welches mir eine darin enthaltene Tabelle automatisch erweitern soll.
Vor einfügen des Schreibschutzes hatte das Makro funktioniert, danach leider nicht mehr!
Ich habe jetzt ein Makro schreiben wollen, welches mir bei Eingabe von grau hinterlegten Zellen das Blatt freigibt und das Makro laufen läßt. Wenn eine weiße Zelle angeklickt wird, dann wird das Blattt wieder gesperrt!
Mit der Sperrung und Freigabe funktioniert alles einwandfrei, bis auf dass das Makro immer noch nicht funktioniert!
Kann mir jemand helfen?
Danke Chris
Hier mein Makro:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim k As Integer
Dim l As Integer
Dim i As Integer
Dim ci As Integer
On Error GoTo ErrorHandler
'Worksheets("Dichtheit Rücklaufsperr-Ventil").Activate
'ci = ActiveCell.Interior.ColorIndex
'If ci = 15 Then
' ActiveSheet.Unprotect ("6666")
Worksheets("Dichheit Rücklaufsperr-Ventil").Activate
If ActiveCell.Interior.ColorIndex = 15 Then
'ActiveSheet.Unprotect ("6666")
GoTo Programmstart
Else
GoTo ende1
End If
Programmstart:
ActiveSheet.Unprotect ("6666")
If Target.Column = 1 And Target.Row > 44 Then
If Target.Value <> "" Then
Rows(Target.Row + 1).Insert
For i = 45 To 60
With Cells(i, 11)
If .Borders(xlEdgeLeft).LineStyle = xlContinuous And _
.Borders(xlEdgeTop).LineStyle = xlContinuous And _
.Borders(xlEdgeBottom).LineStyle = xlContinuous And _
.Borders(xlEdgeRight).LineStyle = xlContinuous Then
.FormulaR1C1 = Cells(40, 11).FormulaR1C1
End If
End With
Next i
ElseIf Target.Row > 45 Then
If Range("A48").Value = "Bemerkung:" Then
GoTo ende
End If
Rows(Target.Row).Delete
Application.ScreenUpdating = True
End If
ende:
End If
' RAHMEN EINGÜGEN
For l = 1 To 11
For k = 45 To 60
Application.ScreenUpdating = False
If Cells(k, 4).Interior.ColorIndex = 15 Then
With Cells(k, l)
.Borders.Weight = xlThin
End With
End If
Next k
Next l
Application.ScreenUpdating = True
ende1:
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ErrorHandler:
If Err.Number = 9 Then
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End If
End Sub