beveiligen gegenereerde (te genereren) tabbladen

[Ericssport]

hey!

ik heb een sheet met data en een sheet met een formulier, uit de sheet met data genereer ik door middel van een macro unieke formulieren/sheets. Nu wil ik alle unieke tabbladen beveiligen, maar als ik het oorspronkelijke formulier beveilig dan neemt de macro de gegevens uit de datasheet niet over, weet iemand hier een oplossing voor?

Hieronder heb ik de datasheet en formulier toegevoegd, de gegevens moeten in kolom B komen.

 

[Warme bakkertje]

Bekijk volgende post eens
http://www.helpmij.nl/forum/showthread.php?t=400789

Mvg

Rudi

 

[Ericssport]

Dank voor de reactie, maar helaas lukt het nog niet helemaal, opzich kan ik wel alle te generen sheets beveiligen (dmv beveiligen blad) maar dan neemt hij de gegevens die de macro uit de datasheet haalt niet op in de nieuwe formulieren op. Opzich is het logisch, maar hoe kan ik dat omzeilen zonder de beveiliging ongedaan te maken?

Ik heb hieronder de macro geplakt.


Sub Eric1()
Dim sWB As String
Dim lRij As Long


sWB = ActiveSheet.Name
lRij = 2
While Worksheets(sWB).Range("A" & lRij).Value <> ""


On Error Resume Next
Sheets("formulier").Select
Sheets("formulier").Copy After:=Worksheets(Worksheets.Count)


Worksheets(Worksheets.Count).Select
Worksheets(Worksheets.Count).Name = Worksheets("Data").Range("a" & lRij).Value


With Worksheets(Worksheets.Count)
.Range("b1").Value = Worksheets(sWB).Range("A" & lRij).Value
.Range("B2").Value = Worksheets(sWB).Range("B" & lRij).Value
.Range("b3").Value = Worksheets(sWB).Range("C" & lRij).Value
.Range("b4").Value = Worksheets(sWB).Range("D" & lRij).Value
.Range("B5").Value = Worksheets(sWB).Range("E" & lRij).Value
.Range("b6").Value = Worksheets(sWB).Range("F" & lRij).Value

End With

lRij = lRij + 1
Wend
End Sub

 

[Warme bakkertje]

Sub Eric1()
Dim sWB As String
Dim lRij As Long
    
   'Gegevens ophalen uit data tabblad
    sWB = ActiveSheet.Name
    lRij = 2
    While Worksheets(sWB).Range("A" & lRij).Value <> ""

         'Genereren formulier
             On Error Resume Next
         [COLOR="Red"]Sheets("formulier").Unprotect[/COLOR]
         Sheets("formulier").Select
         Sheets("formulier").Copy After:=Worksheets(Worksheets.Count)
                                       
                  'Benoemen van de gegenereerde tabbladen
                   Worksheets(Worksheets.Count).Select
                   Worksheets(Worksheets.Count).Name = Worksheets("Data").Range("a" & lRij).Value
                       
           'Waar welke gegevens heen gaan en vandaan komen
            With Worksheets(Worksheets.Count)
                .Range("b1").Value = Worksheets(sWB).Range("A" & lRij).Value 'naam
                .Range("B2").Value = Worksheets(sWB).Range("B" & lRij).Value 'achternaam
                .Range("b3").Value = Worksheets(sWB).Range("C" & lRij).Value 'adres
                .Range("b4").Value = Worksheets(sWB).Range("D" & lRij).Value 'postcode
                .Range("B5").Value = Worksheets(sWB).Range("E" & lRij).Value 'plaats
                .Range("b6").Value = Worksheets(sWB).Range("F" & lRij).Value 'nummer

            End With
        
        lRij = lRij + 1
    Wend
    [COLOR="red"]Sheets("formulier").Protect
For i = 1 To Sheets.Count
    If Sheets(i).Name <> "data" Then
         Sheets(i).Protect
         End If
    Next i[/COLOR]
End Sub

Mvg

Rudi

 

[Ericssport]

Geweldig bedankt Warme bakkertje! Het werkt als een tierrelier! Thanx..

 

[Warme bakkertje]

Als een wat ?? Graag gedaan

Mvg

Rudi