VBA-Schaltfläche bei geschüztem Blatt

[cuba]

Hallo

Habe da eine Frage zu VBA. Ich habe da eine Schaltfläche "Aktualisieren" in meiner Datei.

Ich möchte aber das Tabellenblatt schützen, ein Passwort brauche ich dazu nicht.

Wenn ich das Blatt aber schütze, kommt dann die Meldung Laufzeitfehler 1004; ich soll den Schreibschutz auflösen.

Unten angefügt der bestehende Code. Gibt es dazu eine Lösung?


Sub Schaltfläche2_Klicken()
   Call zusammenfassen
End Sub

Sub zusammenfassen()
   Dim i As Long
   Dim lngLetzte As Long
   Dim vntA
   Dim feld
   Dim objDic1
   Set objDic1 = CreateObject("Scripting.Dictionary")
 
   'Überschriften
   vntA = Array("Order", "KND-Nr.", "Kunde", "Umsatz")
 
   Application.ScreenUpdating = False                   'Bildschirmaktualisierung aus
 
   With Worksheets("AB2015")
      .Columns("g:j").ClearContents                    'Inhalte der Spalten "AC:AF" löschen
      .Range("g3:j3") = vntA                           'Überschriften in den Bereich "AC3:AF3" eintragen
      lngLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row   'letzte belegte Zeile in Spalte A
      feld = .Range("A4:E" & lngLetzte)                  'Bereich AC3 bis AF bis zur letzten belgeten in ein Variant Array schreiben
      For i = LBound(feld) To UBound(feld)               'Alle Array Zeilen durchlaufen
         If feld(i, 1) <> 0 Then                         'wenn Zelle in Spalte nicht 0 dann einlesen
            objDic1(feld(i, 1)) = objDic1(feld(i, 1)) + feld(i, 4)   'Unicate in Dictionary einlesen und die Spalte D aufaddieren
         End If
      Next i
      
      'Daten in die entsprechenden Saplten schreiben
      .Range("h4:h" & objDic1.Count + 3) = WorksheetFunction.Transpose(objDic1.keys) 'Unicate in Spalte AD
      .Range("g4:g" & objDic1.Count + 3) = WorksheetFunction.Transpose(objDic1.items) 'Summen von "St" in Spalte AC
      .Range("i4:i" & objDic1.Count + 3).FormulaLocal = "=SVERWEIS(h4;$A$4:$B$" & lngLetzte & ";2;0)" 'In Spalte AE SVERWEIS() Formel zur Ermittlung der Kundennamen
      .Range("j4:j" & objDic1.Count + 3).FormulaLocal = "=SUMMEWENN($A$4:$A$" & lngLetzte & ";h4;$E$4:$E$" & lngLetzte & ")" ''In Spalte h SUMMEWENN()() Formel zur Ermittlung der Kundennamen
      .Range("i4:i" & objDic1.Count + 3).Value = .Range("i4:i" & objDic1.Count + 3).Value 'Formeln mit ihren Werten überschreiben
      .Range("j4:j" & objDic1.Count + 3).Value = .Range("j4:j" & objDic1.Count + 3).Value ''Formeln mit ihren Werten überschreiben

      
      'erst nach Spalte AC dann nach Spalte AF absteigend sortieren
       .Range("g3:j" & objDic1.Count + 3).Sort Key1:=.Range("g4"), Order1:=xlDescending, Key2:=.Range("j4"), Order2:=xlDescending, Header:=xlYes, _
           OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
           DataOption1:=xlSortNormal
 
   End With
 
   Application.ScreenUpdating = True   'Bildschirmaktualisierung ein

End Sub



LG
cuba

[Kuwer]

Hallo,

Code:

 With Worksheets("AB2015")
   .Unprotect
   .Columns("g:j").ClearContents                    'Inhalte der Spalten "AC:AF" löschen
   ...
   ...
   .Protect
 End With

Gruß Uwe

[cuba]

Hallo Uwe

Vielen Dank für die schnelle Lösung. ABER: Wo soll ich das einfügen?

LG
cuba

[cuba]

Erledigt, funktioniert tadellos!!!

Vielen Dank

LG
cuba

[Steffl]

Hallo,

Code:

ub zusammenfassen()
  Dim i As Long
  Dim lngLetzte As Long
  Dim vntA
  Dim feld
  Dim objDic1
  Set objDic1 = CreateObject("Scripting.Dictionary")
 
  'Überschriften
  vntA = Array("Order", "KND-Nr.", "Kunde", "Umsatz")
 
  Application.ScreenUpdating = False                   'Bildschirmaktualisierung aus
 
  With Worksheets("AB2015")
     .Unprotect                              '<-------- hier eingefügt!
     .Columns("g:j").ClearContents                    'Inhalte der Spalten "AC:AF" löschen
     .Range("g3:j3") = vntA                           'Überschriften in den Bereich "AC3:AF3" eintragen
     lngLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row   'letzte belegte Zeile in Spalte A
     feld = .Range("A4:E" & lngLetzte)                  'Bereich AC3 bis AF bis zur letzten belgeten in ein Variant Array schreiben
     For i = LBound(feld) To UBound(feld)               'Alle Array Zeilen durchlaufen
        If feld(i, 1) <> 0 Then                         'wenn Zelle in Spalte nicht 0 dann einlesen
           objDic1(feld(i, 1)) = objDic1(feld(i, 1)) + feld(i, 4)   'Unicate in Dictionary einlesen und die Spalte D aufaddieren
        End If
     Next i
     
     'Daten in die entsprechenden Saplten schreiben
     .Range("h4:h" & objDic1.Count + 3) = WorksheetFunction.Transpose(objDic1.keys) 'Unicate in Spalte AD
     .Range("g4:g" & objDic1.Count + 3) = WorksheetFunction.Transpose(objDic1.items) 'Summen von "St" in Spalte AC
     .Range("i4:i" & objDic1.Count + 3).FormulaLocal = "=SVERWEIS(h4;$A$4:$B$" & lngLetzte & ";2;0)" 'In Spalte AE SVERWEIS() Formel zur Ermittlung der Kundennamen
     .Range("j4:j" & objDic1.Count + 3).FormulaLocal = "=SUMMEWENN($A$4:$A$" & lngLetzte & ";h4;$E$4:$E$" & lngLetzte & ")" ''In Spalte h SUMMEWENN()() Formel zur Ermittlung der Kundennamen
     .Range("i4:i" & objDic1.Count + 3).Value = .Range("i4:i" & objDic1.Count + 3).Value 'Formeln mit ihren Werten überschreiben
     .Range("j4:j" & objDic1.Count + 3).Value = .Range("j4:j" & objDic1.Count + 3).Value ''Formeln mit ihren Werten überschreiben

     
     'erst nach Spalte AC dann nach Spalte AF absteigend sortieren
      .Range("g3:j" & objDic1.Count + 3).Sort Key1:=.Range("g4"), Order1:=xlDescending, Key2:=.Range("j4"), Order2:=xlDescending, Header:=xlYes, _
          OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
          DataOption1:=xlSortNormal
     .Protect                            '<------------- und hier eingefügt!
 
  End With
 
  Application.ScreenUpdating = True   'Bildschirmaktualisierung ein

End Sub

[cuba]

Danke Stefan

Es hat bereits funkitoniert

LG
cuba