Tabblad beveiligen met paswoord lukt niet door macro

[davylenders123]

Ik heb een bestandje gemaakt waarvan ik het werkblad zou willen beveiligen met een paswoord zodat ze enkel maar
de invul cellen kunnen wijzigen en de andere niet.
Als ik dat doe dan loopt de code van hieronder vast op het rode gedeelte als ik de zelf gemaakte button printen gebruik.

Wat moet er aan de code worden aangepast zodat ik het tabblad wel kan beveiligen met paswoord en de macro toch doet wat hij moet doen?

Sub Knop_printen()
    Application.ScreenUpdating = False
    ActiveSheet.PrintOut copies:=1
    Application.Goto reference:="label2"
    Selection.Copy
    Range("A1:A3").Select
    [COLOR="#FF0000"]ActiveSheet.Paste[/COLOR]
    Range("D1:D3").Select
    Application.CutCopyMode = False
    With Selection
         .HorizontalAlignment = xlGeneral
         .VerticalAlignment = xlBottom
         .WrapText = False
         .Orientation = 0
         .AddIndent = False
         .ShrinkToFit = False
         .MergeCells = False
    End With
    Range("a4").Select
    ActiveSheet.PrintOut copies:=1
    Application.Goto reference:="label3"
    Selection.Copy
    Range("A1:A3").Select
    ActiveSheet.Paste
    Range("D1:D3").Select
    Application.CutCopyMode = False
    With Selection
         .HorizontalAlignment = xlGeneral
         .VerticalAlignment = xlBottom
         .WrapText = False
         .Orientation = 0
         .AddIndent = False
         .ShrinkToFit = False
         .MergeCells = False
    End With
    
    Range("a4").Select
    ActiveSheet.PrintOut copies:=1
    Application.ScreenUpdating = True
    ThisWorkbook.Close savechanges:=False
End Sub

Bekijk bijlage VERDOVING VOP.xls

 

[koster1984]

Begin je code (op de 2e regel) met:

Sheets("Blad1").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="[COLOR="#FF0000"]Hier je wachtwoord[/COLOR]"

En eindig (op de op één na laatste regel) met:

Sheets("Blad1").Unprotect Password:="[COLOR="#FF0000"]Hier je wachtwoord[/COLOR]"

 

[davylenders123]

koster1984

Heb de code aangepast zoals je hebt gezegd maar de code loopt op dezelfde plaats vast.

Sub Knop_printen()
Sheets("Blad1").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="1230"
    Application.ScreenUpdating = False
    ActiveSheet.PrintOut copies:=1
    Application.Goto reference:="label2"
    Selection.Copy
    Range("A1:A3").Select
    [COLOR="#FF0000"]ActiveSheet.Paste[/COLOR]
    Range("D1:D3").Select
    Application.CutCopyMode = False
    With Selection
         .HorizontalAlignment = xlGeneral
         .VerticalAlignment = xlBottom
         .WrapText = False
         .Orientation = 0
         .AddIndent = False
         .ShrinkToFit = False
         .MergeCells = False
    End With
    Range("a4").Select
    ActiveSheet.PrintOut copies:=1
    Application.Goto reference:="label3"
    Selection.Copy
    Range("A1:A3").Select
    ActiveSheet.Paste
    Range("D1:D3").Select
    Application.CutCopyMode = False
    With Selection
         .HorizontalAlignment = xlGeneral
         .VerticalAlignment = xlBottom
         .WrapText = False
         .Orientation = 0
         .AddIndent = False
         .ShrinkToFit = False
         .MergeCells = False
    End With
    
    Range("a4").Select
    ActiveSheet.PrintOut copies:=1
    Application.ScreenUpdating = True
    ThisWorkbook.Close savechanges:=False
    Sheets("Blad1").Unprotect Password:="1230"
End Sub

 

[Cobbe]

Het moet natuurlijk net omgekeerd, Unprotect eerst en dan Protect.

 

[davylenders123]

Bedankt.:thumb:

Zo werkt het natuurlijk wel

 

[koster1984]

Klopt Cobbe, even verkeerd om opgeschreven.

Maar.. ik vraag me af.. werkt het überhaupt wel met excel 2003? (als ik hem vanuit zijn bestand opneem maakt ie geen regel voor het password).

 

[davylenders123]

koster1984

Het werkt zo onder 2003 heb juist nog op het netwerk van het werk gezet en daar draait enkel excel 2003 en werkt zo perfect.

Nog eens bedankt voor de hulp:thumb:

 

[koster1984]

Mooi.. Succes ermee

 

[Cobbe]

Werkt ook voor Xl2000-2003, net opgenomen, enkel het paswoord moet je nog tussenfoefelen:

Sub Macro1()
'
' Macro1 Macro
' De macro is opgenomen op 14/09/2012 door albertdernier.
'

'
    Range("E7:F21").Select
    Selection.FormulaArray = "15"
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub

 

[Roncancio]

Als je UserInterfaceOnly gebruikt hoef je de beveiliging er niet af te halen.
De cellen kunnen dan uitsluitend via macro's gewijzigd worden en dus niet meer handmatig.

Je code kan overigens nog wat korter.

Sub Knop_printen()
Dim iTel As Integer
    Sheets(1).Protect "1230", UserInterfaceOnly:=True
    ActiveSheet.PrintOut copies:=1
    For iTel = 2 To 3
        Range("A1:A3").Value = Range("label" & iTel).Value
        ActiveSheet.PrintOut copies:=1
    Next
     ThisWorkbook.Close savechanges:=False
    
End Sub

Met vriendelijke groet,


Roncancio

 

[davylenders123]

Roncancio

U code werkt ook perfect.

Bedankt:thumb:

 

[davylenders123]

Roncancio

U code doet toch nog een klein dingske teweining.
Op rij 61/62 en 65/66 in het bestand staat wat op de 2 andere blz moet komen te staan.
Hier neemt hij echter maar het eerste stukje van over.
Vb op blz 2 zet hij 2 exemplaar voor dg 86 turnhout in plaats van 2 exemplaar voor chauffeur
Blz 3 het zelfde zet hij op 3 exemplaar voor dg 86 turnhout in plaats van 3 exemplaar voor dg 87 st niklaas.

Wat moet ik nog aan de code wijzigen om dit kleine probleempje nog op te lossen ?

 

[Roncancio]

Ik zie maar 1 blad in je voorbeeld bestand.
Het is mij dus niet helemaal duidelijk hoe je het wilt hebben.

Met vriendelijke groet,


Roncancio

 

[Cobbe]

Zo zal die wel doen wat je wil:

Sub Knop_printen()
    Application.ScreenUpdating = False
Activesheet.Unprotect
'Blad 1
    ActiveSheet.PrintPreview 'Out copies:=1
'Blad 2
    [A1] = 2: [D2] = "Dg 87 St.Niklaas"
    ActiveSheet.PrintPreview 'Out copies:=1
'Blad 3
    [A1] = 3: [D2] = "Chauffeur"
    ActiveSheet.PrintPreview 'Out copies:=1
'afsluiten
    Application.ScreenUpdating = True
Activesheet.Protect
    ThisWorkbook.Close savechanges:=False
End Sub