Range beveiligde cellen wijzigen

[Feijtert]

Hallo,

Ik heb een bestand gemaakt voor het scannen van producten. Het originele bestand bestaat uit meerdere tabbladen. In dit bestand scant de medewerker het product in kolom B. Vervolgens worden alle gegevens automatisch opgehaald uit een ander tabblad en voert de medewerker het getelde aantal in.

Om het systeem '******proof' te maken, probeer ik een vba te maken die alle ingevulde cellen (behalve die van kolom E en G) automatisch blokkeert. Daarnaast moet een andere macro het mogelijk maken om de gegevens in de lastrow (kolom B t/m H te verwijderen. Het kan namelijk wel eens gebeuren dat de medewerker net het verkeerde product scant of een verkeerd aantal invoert. Probleem is echter dat een andere macro alle cellen waar een waarde in staat beveiligd.

Onderstaande code beveiligd alle gevulde cellen. Echter, de cellen in de kolommen E en G mogen niet beveiligd worden.

Private Sub Worksheet_Change(ByVal Target As Range)


Application.ScreenUpdating = False
ActiveSheet.Unprotect
Selection.SpecialCells(xlCellTypeConstants, 23).Select
Selection.Locked = True
Selection.FormulaHidden = False
Range("a65536").End(xlUp).Offset(2, 0).Select

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True, AllowInsertingHyperlinks:=True

Met de onderstaand code lukt het mij om 1 cel uit de laatste rij te verwijderen, maar dmv van offset zouden de waarden in de 6 cellen rechts van de actieve cel ook verwijderd moeten worden. Echter, de bovenstaande code verhinderd dit voortdurend door continue alles te beveiligen.

ActiveSheet.Unprotect

Range("B1000").End(xlUp).Select

Selection.ClearContents

Ik hoop dat iemand een oplossing heeft.

Alvast vriendelijk bedankt!


Groeten Arjen

 

[snb]

Vermijd select en activate in VBA-code

Private Sub Worksheet_Change(ByVal Target As Range)
  Application.ScreenUpdating = False
  with ActiveSheet
    .Unprotect
    with .cells.SpecialCells(xlCellTypeConstants, 23)
       .Locked = True
       .FormulaHidden = False
    end with
    .Protect
  End with
  Application.ScreenUpdating = True
End Sub

Sub weg()
   With Sheets(1)
     .Unprotect
     .cells(rows.count,2).End(xlUp).resize(,6).ClearContents
     .Protect
   End With
End Sub

 

[Feijtert]

Bedankt snb!

Deze codes zien er wat strakker uit. Ik heb nog wel een vraag. De tweede code verwijderd netjes de waarden uit de laatste rij. Het is daarna echter niet meer mogelijk om nog iets in te vullen in deze rij omdat de andere macro deze cellen weer direct beveiligd. Is het niet mogelijk dat de gegevens verwijderd worden en de beveiliging ook van deze cellen af gaat?

Verder zou de 1e code de kolommen E en G eigenlijk niet mogen blokkeren.

 

[snb]

Is het niet mogelijk dat de gegevens verwijderd worden en de beveiliging ook van deze cellen af gaat?

Mij lijkt dat je dat zelf eenvoudig kunt aanpassen in de code die ik gaf.

 

[Feijtert]

Dat had ik al geprobeerd. Omdat ik ervan wil leren, probeer ik het altijd eerst zelf op te lossen. Maar nu loop ik steeds vast.

Om de beveiliging van de kolommen E en G eraf te halen, wil ik de volgende code verwerken:

With ActiveSheet
.Unprotect
With .Range("E1:E1000").Locked = False
End With

Probleem is alleen dat de andere code de cellen met waarden beveiligd. Het lukt mij niet om bovenstaande code te integreren in de reeds gemaakte code.

Ik hoop dat je nog een keer bereid bent om te helpen

 

[Feijtert]

Ik denk het nu opgelost te hebben. De codes zijn vast voor verbetering vatbaar, maar ze werken. Wanneer de medewerker een code heeft gescand in kolom B, dan blokkeert de betreffende cel. In principe is dit al voldoende. Het gaat er voornamelijk om dat er geen code over een andere code wordt gescand.


Private Sub Worksheet_Change(ByVal Target As Range)


Dim Rng
Dim MyCell
Set Rng = Range("B8:B1000")
For Each MyCell In Rng
If MyCell.Value = "" Then

Else: ActiveSheet.Unprotect
MyCell.Locked = True
MyCell.FormulaHidden = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveSheet.EnableSelection = xlNoRestrictions
End If
Next



On Error GoTo errhand
If Target.Cells.Count = 1 And Not Intersect(Target, Range("E8:E1000")) Is Nothing Then
Application.EnableEvents = False
If UCase(Target.Value) <> "" Then
Me.Unprotect
Target.Offset(0, 2).Locked = True
Me.Protect
Else
Me.Unprotect
Target.Offset(0, 2).Locked = False
Me.Protect
End If
End If




On Error GoTo errhand
If Target.Cells.Count = 1 And Not Intersect(Target, Range("G8:G1000")) Is Nothing Then
Application.EnableEvents = False
If UCase(Target.Value) <> "" Then
Me.Unprotect
Target.Offset(0, -2).Locked = True
Me.Protect
Else
Me.Unprotect
Target.Offset(0, -2).Locked = False
Me.Protect
End If
End If
errhand:
Application.EnableEvents = True