Automatisch nieuw werkblad aanmaken en beveiligen

Status
Niet open voor verdere reacties.
L

Leekje2010

Gebruiker
Lid geworden
29 aug 2010
Berichten
7
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo einde
With Target
If Target.Column = 2 Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = Target
Cells(Target.Row, 5).Value = Cells(Target.Row, 2).Value
End If
End With
Sheets("hoofd").Range("1:76").Copy Sheets(Sheets.Count).Range("1:76")
Sheets(Sheets.Count).Columns.AutoFit
einde:
End Sub
Klik om te vergroten...

Met behulp van veel snuffelwerk heb ik in mijn excelbestand bovenstaande code ingevoerd en deze code werkt perfect om bij invoer van een nieuwe naam in een kolom (2e , op werkblad "TOTALEN", is het actieve werkblad) een nieuw werkblad aan te maken, wat een kopie is van het werkblad "HOOFD" én met de naam van de naam die is ingevoerd in de cel in de 2e kolom.
Nu merkte ik dat, wanneer ik het werkblad HOOFD beveilig, dat alleen het format wordt gekopieerd en níet alle formules, etc. op de pagina. Ik wil die pagina graag wel beveiligen om te voorkomen dat andere mensen die met het bestand werken per ongeluk het moedermodel en de formules wissen. Ik krijg het niet voor elkaar met de code sheets ("").unprotect en .protect en weet ook niet waar deze te plaatsen.

Tevens zou het werkblad dat wordt aangemaakt ook direct bij het aanmaken beveiligd willen hebben (tenminste, niet de cellen die ik op het werkblad "hoofd" heb aangegeven als invulbaar (niet-vergendeld), maar de rest wel).
Is het mogelijk om dit met een (aanpassing van de) code voor elkaar te krijgen?

Als laatste zou ik graag willen dat op de actieve pagina (Totalen) een melding komt wanneer ik in die 2e kolom een naam invoer die al eerder in die kolom is gebruikt (er wordt dan nl geen werkblad aangemaakt), zodat er een andere naam wordt ingevoerd. Ik hoop dat iemand me kan helpen om dit allemaal in 1 code te krijgen.
 
Verwoede poging zonder voorbeeld bestand:
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Columns(2)) Is Nothing Then
        With Sheets.Add(, Sheets(Sheets.Count))
            .Name = Target.Value
            .Cells(Target.Row, 5).Value = .Cells(Target.Row, 2).Value
            .Columns.AutoFit
            With Sheets("hoofd")
                .Unprotect "wachtwoord"
                .Range("1:76").Copy Sheets(Target.Value).Range("1:76")
                .Protect "wachtwoord"
            End With
            .Protect "wachtwoord"
        End With
    End If
End Sub
 
Met naamcontrole.
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Value = vbNullString Or Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Columns(2)) Is Nothing Then
        If WorksheetFunction.CountIf(Columns(2), Target.Value) > 1 Then
            MsgBox "Naam is al aanwezig !! Gebruik een andere naam."
            Target.Value = vbNullString
            Exit Sub
        End If
        Cells(Target.Row, 5).Value = Cells(Target.Row, 2).Value
        Application.ScreenUpdating = False
        With Sheets("hoofd")
            .Unprotect "wachtwoord"
            .Copy , Sheets(Sheets.Count)
            .Protect "wachtwoord"
        End With
        With Sheets(Sheets.Count)
            .Name = Target.Value
            .Columns.AutoFit
            .Protect "wachtwoord"
        End With
    End If
    Application.ScreenUpdating = True
    Application.Goto Sheets("Totalen").Range("A1")
End Sub
 
Laatst bewerkt:
Mag ik het woord "briljant" in de mond nemen! Het werkt perfect! De nieuwe werkbladen worden met formules aangemaakt en zijn keurig beveiligd!

Ik heb nog twee vragen:
Over het laatste deel: een melding met een tekst, die komt wanneer er in een cel in kolom 2 een naam wordt ingevoerd die al elders in een cel in die kolom staat. (Zodat mensen weten dat deze naam al bestaat en ze een andere naam moeten kiezen). Ik had daar een code voor gevonden met MsgBox, maar krijg dat niet werkend.

En: hoe zorg ik ervoor dat het format exact wordt gekopieerd: dus mét de juiste kolombreedtes als in het moedermodel "HOOFD".
 
Echt hoor! Sneller dan het licht! De tweede code heb ik nu ook gebruikt (met de messagebox) en dit werkt ook top! Uren met deze twee dingen bezig geweest!
 
Heb je mijn code al eens getest ?

edit: antwoord was sneller dan mijn vraag :)
 
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Value = vbNullString Or Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Columns(2)) Is Nothing Then
If WorksheetFunction.CountIf(Columns(2), Target.Value) > 1 Then
MsgBox "Naam is al aanwezig !! Gebruik een andere naam."
Target.Value = vbNullString
Exit Sub
End If
Cells(Target.Row, 5).Value = Cells(Target.Row, 2).Value
Application.ScreenUpdating = False
With Sheets("hoofd")
.Unprotect "HOOFD!"
.Copy , Sheets(Sheets.Count)
.Protect "HOOFD!"
End With
With Sheets(Sheets.Count)
.Name = Target.Value
.Columns.AutoFit
.Protect "HOOFD!"
End With
End If
Application.ScreenUpdating = True
Application.Goto Sheets("Totalen").Range("A1")
End Sub
Klik om te vergroten...

Ik heb je code geprobeerd (met messagebox) en deze werkte de eerste keer goed en toen deed ik het nog een keer (ook na weer sluiten en openen bestand) en nu krijg ik een foutmelding en wordt overgegaan naar VBA foutopsporing. Wat doe ik verkeerd?
 
Welke regel kleurt er geel bij de foutopsporing ?
 
Het lijkt nu te zijn gelukt door jullie codes (Spaarie en Warm Bakkertje) te combineren tot:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Value = vbNullString Or Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Columns(2)) Is Nothing Then
If WorksheetFunction.CountIf(Columns(2), Target.Value) > 1 Then
MsgBox "Naam is al aanwezig !! Gebruik een andere naam."
Target.Value = vbNullString
Exit Sub
END IF
With Sheets.Add(, Sheets(Sheets.Count))
.Name = Target.Value
.Cells(Target.Row, 5).Value = .Cells(Target.Row, 2).Value
.Columns.AutoFit
With Sheets("hoofd")
.Unprotect "HOOFD!"
.Range("1:76").Copy Sheets(Target.Value).Range("1:76")
.Protect "HOOFD!"
End With
.Protect "HOOFD!"
End With
End If
End Sub
Klik om te vergroten...

Ik krijg nu keurig een message box bij een dubbele naam en het beveiligingsstuk werkt zo te zien ook prima. Zit ik eigenlijk alleen nog met het feit dat ik het moedermodel het liefst precies over wil nemen, dus inclusief de kolombreedtes zoals die op het model staan. Ik heb wel codes gevonden om dat per kolom te definieren, maar het gaat om iets van 18 kolommen met allemaal een andere breedte. Is er ipv Columns.Autofit niet een code die dit juist niet doet en de kolombreedtes precies overneemt van het model?
 
Kun je code tags gebruiken in plaats van quote tags ?

waarom niet simpel

Code: 
if target.column=2 then

end if
 
Laatst bewerkt:
Wat je fout doet weet ik niet maar deze blijft het altijd doen, zelfs na 10 keer proberen-opslaan-sluiten-heropenen-opnieuw uitvoeren-alles zonder foutmeldingen.
Alles wordt keurig overgenomen, zelfs kolombreedtes.
Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Value = vbNullString Or Target.Cells.Count > 1 Then Exit Sub
    If Target.Column = 2 Then
        If WorksheetFunction.CountIf(Columns(2), Target.Value) > 1 Then
            MsgBox "Naam is al aanwezig !! Gebruik een andere naam."
            Target.Value = vbNullString
            Exit Sub
        End If
        Target.Offset(, 3).Value = Target.Value
        Application.ScreenUpdating = False
        With Sheets("hoofd")
            .Unprotect "wachtwoord"
            .Copy , Sheets(Sheets.Count)
            .Protect "wachtwoord"
        End With
        With Sheets(Sheets.Count)
            .Name = Target.Value
            .Protect "wachtwoord"
        End With
    End If
    Application.ScreenUpdating = True
    Application.Goto Sheets("Totalen").Range("A1")
End Sub
 
Heb je nog andere gebeurteniscodes in het werkblad of het werkboek staan die roet in het eten kunnen gooien ?
 
De regel waarop de foutmelding komt is:
Code: 
Cells(Target.Row, 5).Value = Cells(Target.Row, 2).Value
dit komt volgens mij omdat de waarde in kolom B wordt overschreven door de waarde uit kolom E midden in de change event.

In mijn 1e code (die niet helemaal compleet was) heb ik dit uit laten voeren op het nieuw aangemaakte tabblad. Rudi neemt deze waarde over op het blad waar de code achter staat, dus het actieve blad.
In de nieuwe code heeft Rudi ie het ondervangen door
Code: 
Target.Offset(, 3).Value = Target.Value
 
Warme bakkertje, Spaarie en snb. Enorm bedankt voor jullie hulp!
De laatste complete code werkt precies zoals gewenst. Ik leer steeds meer bij!
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan