Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1000to1004
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Blattschutz per Makro

Blattschutz per Makro
20.08.2008 23:45:00
oblivion
Hallo, bei mir steht im Blatt "Gesamt" der folgende Code. Früher war es kein Problem mit hilfe der Befehle unprotect und protect das Blatt "Gesamtdaten" zu schützen. Nur ist der Code etwas größer geworden, bzw. es wird ein weiteres Makro abgespielt. Weiß jemand wie ich mein Makro ändern muss, damit die wieder funktioniert.
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Tab2 As Range, rowOffset As Long, strAdress As String
Dim B As Long, A As Long, C As Long
Sheets("Gesamtdaten").Unprotect "gesamtdaten"
If Not Intersect(Target, Range("B3")) Is Nothing Then
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
On Error GoTo Fehler1:
With Tabelle2
rowOffset = .Rows(2).Find(What:=Range("B3"), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Column - 3
Range("B5:B" & Rows.Count).ClearContents
strAdress = .Range(.Cells(4, rowOffset), _
.Cells(56, rowOffset)).Address
.Range(strAdress).Copy Range("B5")
Range("E5:G" & Rows.Count).ClearContents
strAdress = .Range(.Cells(4, rowOffset + 1), _
.Cells(56, rowOffset + 5)).Address
.Range(strAdress).Copy Range("C5")
End With
ElseIf Not Intersect(Target, Columns(11)) Is Nothing Then
ArztAnlegen Intersect(Target, Columns(11))
Me.Activate
End If
Fehler1:
AnzeigeAn
If Err.Number  0 Then
MsgBox Err.Description, vbCritical, "Fehler beim Lesen!"
Sheets("Gesamtdaten").Protect "gesamtdaten"
Exit Sub
End If
On Error GoTo Fehler:
If Selection.Count > 1 Then
For C = 1 To Selection.Count
If Intersect(Selection(C), Range("E5:G56", "B5:B56")) Is Nothing Then _
Exit Sub
AnzeigeAn
B = Tabelle2.Rows(2).Find(What:=Range("B3"), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Column - 2
For A = 0 To 5
If A  3 Then
If A = 5 Then
Tabelle2.Cells(Selection(C).Row - 1, B - 1) = _
Cells(Selection(C).Row, 2).Value
Else
Tabelle2.Cells(Selection(C).Row - 1, B + A).Value = _
Cells(Selection(C).Row, 3 + A).Value
End If
End If
Next A
Next C
Else
If Intersect(Target, Range("E5:G56", "B5:B56")) Is Nothing Then Exit Sub
AnzeigeAn
B = Tabelle2.Rows(2).Find(What:=Range("B3"), LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Column - 2
For A = 0 To 5
If A  3 Then
If A = 5 Then
Tabelle2.Cells(Target.Row - 1, B - 1) = Cells(Target.Row, 2).Value
Else
Debug.Print Cells(Target.Row, 3 + A)
Tabelle2.Cells(Target.Row - 1, B + A).Value = _
Cells(Target.Row, 3 + A).Value
End If
End If
Next A
End If
Fehler:
AnzeigeAn
If Err.Number  0 Then MsgBox Err.Description, vbCritical, _
"Fehler beim schreiben!"
Sheets("Gesamtdaten").Protect "gesamtdaten"
End Sub



Private Sub ArztAnlegen(rngB As Range)
Dim rngK As Range, lngI As Long
For Each rngK In rngB
If rngK.Row > 1 Then
If Len(rngK)  "" Then
For lngI = 1 To Sheets.Count
If Sheets(lngI).Name = "" & rngK Then
MsgBox "Das Blatt " & rngK & " gibt es schon!"
Exit For
End If
Next lngI
If lngI > Sheets.Count Then
Sheets("Muster").Copy After:=Sheets(lngI - 1)
With ActiveSheet
.Name = rngK
.Cells(7, 3) = rngK
.Protect Password:=rngK
End With
End If
End If
End If
Next rngK
End Sub



Private Sub AnzeigeAn()
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Sheets("Gesamtdaten").Protect "gesamtdaten"
End Sub


Sub Gesamt()
Application.EnableEvents = True
Sheets("Gesamtdaten").Protect "gesamtdaten"
End Sub


Danke für die Antworten.
Gruß Oblivion

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Blattschutz per Makro
21.08.2008 08:09:00
oblivion
hallo, ich habe das Problem selber lösen können. Hatte ein paar protect-Befehle zu viel drinnen. Gruß Oblivion
Anzeige

299 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige