Microsoft Excel

Herbers Excel/VBA-Archiv

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

Blattschutz per Makro

Betrifft: Blattschutz per Makro von: oblivion
Geschrieben am: 20.08.2008 23:45:48

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) < 32 And 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

  

Betrifft: AW: Blattschutz per Makro von: oblivion
Geschrieben am: 21.08.2008 08:09:40

hallo, ich habe das Problem selber lösen können. Hatte ein paar protect-Befehle zu viel drinnen. Gruß Oblivion


 

Beiträge aus den Excel-Beispielen zum Thema "Blattschutz per Makro"