beveiligde bladen print niet met VBA

[buckeru]

Beste,

Ik heb de volgende code en die werkt perfect.

Sub Verwerk_en_Invoer_wissen()

     
        'Printopdracht instellen op basis van de waarde op tabblad Invoer cel D7
    With Sheets("Invoer")
       If .Range("D7") <> "" Then
       area = "Print_" & UCase(Range("D7").Value)
       Range(area).PrintPreview
       End If
    End With
    
        'Data van Invoer tabblad (D7,F7,H7 en J7), kopieren naar tabblad Oud, en vanaf boven
        'af aan invoegen cel A2
    Set ws = Worksheets("Oud")
        ws.Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        ws.Rows("2:2").Resize(, 7).Value = Array([D7], "", [F7], "", [H7], "", [J7])
        Range("Wissen").ClearContents       'invoer velden op tabblad Invoer worden gewist
        ws.Rows("2:2").Interior.Color = xlNone
        ws.Range("D2") = ws.Range("D3").FormulaR1C1
        

End Sub

Eigenlijk wil ik de tabbladen verbergen en beveiligen. zie code.
Maar helaas loopt de code nu vast bij Range(area).PrintPreview. Bij area staat nu alleen "Print_" en cel D7 leeg

Sub Verwerk_en_Invoer_wissen()

Dim mijnBlad As Worksheet
        'Tab bladen zichtbaar maken
    Dim i As Integer
    For i = 2 To Worksheets.Count
    With Worksheets(i)
    .Visible = True
    End With
    Next i
    
        'Beveiliging er af halen
    For Each Worksheet In ActiveWorkbook.Worksheets
    Worksheet.Unprotect Password:="pop"
    Next
    
        'Printopdracht instellen op basis van de waarde op tabblad Invoer cel D7
    With Sheets("Invoer")
       If .Range("D7") <> "" Then
       area = "Print_" & UCase(Range("D7").Value)
       Range(area).PrintPreview
       End If
    End With
    
        'Data van Invoer tabblad (D7,F7,H7 en J7), kopieren naar tabblad Oud, en vanaf boven
        'af aan invoegen cel A2
    Set ws = Worksheets("Oud")
        ws.Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        ws.Rows("2:2").Resize(, 7).Value = Array([D7], "", [F7], "", [H7], "", [J7])
        Range("Wissen").ClearContents       'invoer velden op tabblad Invoer worden gewist
        ws.Rows("2:2").Interior.Color = xlNone
        ws.Range("D2") = ws.Range("D3").FormulaR1C1
    
        'Beveiliging er op zetten
    For Each Worksheet In ActiveWorkbook.Worksheets
    Worksheet.Protect Password:="pop"
    Next
    
    Dim Blad As Worksheet
        'Tab bladen verbergen
    Dim x As Integer
    For x = 2 To Worksheets.Count
    With Worksheets(x)
    .Visible = False
    End With
    Next x
    



End Sub

Wie kan mij helpen?

grtn Buck

 

[Cobbe]

Test deze eens:

Sub Verwerk_en_Invoer_wissen_test_Cobbe()    ' Cobbe test

Dim mijnBlad As Worksheet
         'Beveiliging er af halen en zichtbaar maken
    For Each ws In ActiveWorkbook.Worksheets
        ws.Unprotect Password:="pop"
       If ws.Name <> [COLOR="#FF0000"]"Invoer"[/COLOR] Then
        ws.Visible = True
       End If
    Next
 
        'Printopdracht instellen op basis van de waarde op tabblad Invoer cel D7
    With Sheets("Invoer")
       If .Range("D7") <> "" Then
       Set Area = Range("Print_" & UCase(.Range("D7").Value))
       Area.PrintPreview
       End If
    End With
    
     'Data van Invoer tabblad (D7,F7,H7 en J7), kopieren naar tabblad Oud, en vanaf boven
        'af aan invoegen cel A2
    Set ws = Worksheets("Oud")
        ws.Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        ws.Rows("2:2").Resize(, 7).Value = Array([D7], "", [F7], "", [H7], "", [J7])
        [COLOR="#FF0000"]Range("Wissen"  ).ClearContents[/COLOR]       'invoer velden op tabblad Invoer worden gewist
        ws.Rows("2:2").Interior.Color = xlNone
        ws.Range("D2") = ws.Range("D3").FormulaR1C1
    
        'Beveiliging er op zetten
    For Each ws In ActiveWorkbook.Worksheets
      ws.Protect Password:="pop"
       If ws.Name <> "Invoer" Then
        ws.Visible = False
       End If
    Next

End Sub

 

[buckeru]

Thanks Cobbe,

Maar het werkt nog niet goed.
heb er even een voorbeeld bij gedaan

 

[Cobbe]

Je moest ook Blad1 vervangen door Invoer en de ' weghalen voor het ClearContents commando.

Dan doet hij het denk ik zo.

 

[buckeru]

Helaas, het gaat mij niet lukken.
loopt hier vast
Set Area = Range("Print_" & UCase(Range("D7").Value))

Als ik de macro knop gebruik loopt hij vast
als ik op F5 (afspelen) druk in VBA
lijkt het goed te gaan.

kan de fout niet vinden

 

[Cobbe]

 Set Area = Range("Print_" & UCase([COLOR="#FF0000"].[/COLOR]Range("D7").Value))

Doe dan deze eens.

 

[buckeru]

Macro loopt nu mooi door met die punt erbij.
Alleen kopieert hij de bestanden van invoer naar Oud niet?

 

[Cobbe]

En nu?

Sub Verwerk_en_Invoer_wissen_test_Cobbe()    ' Cobbe test

Dim mijnBlad As Worksheet
         'Beveiliging er af halen en zichtbaar maken
    For Each ws In ActiveWorkbook.Worksheets
        ws.Unprotect Password:="pop"
       If ws.Name <> "Invoer" Then
        ws.Visible = True
       End If
    Next
 
        'Printopdracht instellen op basis van de waarde op tabblad Invoer cel D7
    With Sheets("Invoer")
       If .Range("D7") <> "" Then
       Set Area = Range("Print_" & UCase(.Range("D7").Value))
       Area.PrintPreview
       End If
    End With
    
     'Data van Invoer tabblad (D7,F7,H7 en J7), kopieren naar tabblad Oud, en vanaf boven
        'af aan invoegen cel A2
    Set ws = Worksheets("Oud")
        ws.Rows("2:2").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
         Range("Wissen").Copy
           ws.Cells(2, "B").PasteSpecial Paste:=xlValues
         Range("Wissen").ClearContents       'invoer velden op tabblad Invoer worden gewist
'        ws.Rows("2:2").Interior.Color = xlNone
'        ws.Range("D2") = ws.Range("D3").FormulaR1C1
    
        'Beveiliging er op zetten
    For Each ws In ActiveWorkbook.Worksheets
      ws.Protect Password:="pop"
       If ws.Name <> "Invoer" Then
        ws.Visible = False
       End If
    Next

End Sub

 

[buckeru]

Ok, na wat kleine aanpassingen in mijn sheet, gaat het lukken met de laaste code.

super bedankt. Ik ga nog proberen het te kopieren stuk van "Invoer" naar een ander bestand op het netwerk ipv naar "Oud" in
deze sheet.

ik zet hem op opgelost.
thnx Buck