Condividi:        

Macro protezione foglio con password non funge

Vuoi potenziare i tuoi documenti Word? Non sai come si fa una macro in Excel? Devi creare una presentazione in PowerPoint?
Oppure sei passato a OpenOffice e non sei sicuro di come lavorare al meglio?

Moderatori: Anthony47, Flash30005

Macro protezione foglio con password non funge

Postdi xilofono » 22/01/24 20:00

Ho una macro che in apertura toglie la protezione con password e in chiusura, dopo aver fatto le operazioni che deve, dovrebbe rimetterla risettando la password

Funziona in fase di togliere la protezione (anche se il foglio è protetto da pass), mentre quando deve rimettere la protezione, lo fa, ma non risulta alcuna password inserita

Non riesco a capire perchè!
Le due righe sono queste, la prima funziona, la seconda no..

Codice: Seleziona tutto
ActiveSheet.Unprotect ("password")

ActiveSheet.Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True


Dove sta l'errore?!
Anche provando varianti tipo

Codice: Seleziona tutto
ActiveSheet.Protect ("password")


Il risultato è il medesimo: il foglio viene protetto, ma senza password.

* Inoltre vorrei se possibile fare due variazioni:
Questo però non so farlo proprio, se qualcuno ha la pazienza di spiegarmi come potrei ottenere il risultato gliene sarei grato :lol:

- aggiungere prima della prima riga (quella che toglie la protezione) una variabile che, se nella cella S14 il valore è "No" (risultante di una formula di controllo del foglio) mi apre un MsgBox che mi informa che i dati non sono corretti e che mi consente di rispondere "Ok" e a quel punto fa Goto finesub

- aggiungere alla seconda riga (quella che protegge il foglio) una variabile, per cui se si è raggiunta una certa data settata nello stesso codice, poniamo per esempio il 31-03-2025 , la password non è più "password" ma "wordpass"

Un caro saluto alla community e un grazie a chi vorrà aiutarmi :oops:
Windows 11 - Office 2016 Ita
Avatar utente
xilofono
Utente Junior
 
Post: 80
Iscritto il: 27/11/17 09:52

Sponsor
 

Re: Macro protezione foglio con password non funge

Postdi Anthony47 » 22/01/24 22:22

Ovviamente sul mio Pc, con
Codice: Seleziona tutto
ActiveSheet.Unprotect Password:="Password"
'...
ActiveSheet.Protect Password:="Password"
il tutto funziona come deve.
Quindi credo che bisogna guardare il tuo codice complessivo e la sua posizione (in quale modulo si trova)

Questo aiutera' anche per le modifiche richieste
Avatar utente
Anthony47
Moderatore
 
Post: 19387
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Macro protezione foglio con password non funge

Postdi xilofono » 22/01/24 22:30

Il Codice completo è questo

Codice: Seleziona tutto

Private Sub Registra_Merce_Click()

 Azione = MsgBox("Verificare i dati inseriti. Procedere?", vbYesNo, "Conferma") 'mex introduzione
If Azione = vbNo Then GoTo finesub




ActiveSheet.Unprotect ("password") 'toglie protezione


Dim myNext As Long 'registra dati
'Application.ScreenUpdating = False
Application.EnableEvents = False
myNext = Sheets("Tracciabilità Carne").Cells(Rows.Count, "b").End(xlUp).Row + 1
Sheets("Tracciabilità Carne").Cells(myNext, "b").Resize(6, 9).Value = Sheets("Tracciabilità Carne").Range("q1:y6").Value

Application.EnableEvents = True
'Application.ScreenUpdating = True
   
 
   
    Range("B3:G8").Select 'pulizia campo compilazione
    Range("G8").Activate
    Selection.ClearContents


    Range("J10:J16").Select 'toglie filtri
    Selection.ClearContents
   
       Range("B19:J40000").Select 'ordina

    ActiveWorkbook.Worksheets("Tracciabilità Carne").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Tracciabilità Carne").Sort.SortFields.Add Key:= _
        Range("B19:B40000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    ActiveWorkbook.Worksheets("Tracciabilità Carne").Sort.SortFields.Add Key:= _
        Range("C19:C40000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("Tracciabilità Carne").Sort
        .SetRange Range("B18:J40000")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   
    Range("b18").End(xlDown).Select 'seleziona ultima riga colB
   
    ActiveSheet.Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True  'protezione foglio
   
     ActiveWorkbook.Save  'salvataggio

finesub:
    Range("b3").Select 'se non si accetta la macro va dritto qui
   
End Sub


applicato a questo foglio (in cui girano altre macro)

https://we.tl/t-RmJxi85jfe

la password è "password"
Windows 11 - Office 2016 Ita
Avatar utente
xilofono
Utente Junior
 
Post: 80
Iscritto il: 27/11/17 09:52

Re: Macro protezione foglio con password non funge

Postdi Anthony47 » 22/01/24 23:21

La tua Sub Registra_Merce_Click modifica dei dati che attivano l'evento Worksheet_Change, che al suo interno contiene
Codice: Seleziona tutto
    Application.EnableEvents = False
    ActiveSheet.Unprotect
        ActiveSheet.Range("$r$18:$r$" & UR).AutoFilter Field:=1, Criteria1:="<>0"
    ActiveSheet.Protect
    Application.EnableEvents = True

Quindi quando l'evento Worksheet_Change si completa e restituisce il controllo alla Sub Registra_Merce_Click il foglio e' gia' protetto ma senza password.
L'ulteriore ActiveSheet.Protect Password:="password" viene ignorato

Lo puoi collaudare con questa semplice macro:
Codice: Seleziona tutto
Sub miooo()
ActiveSheet.Unprotect Password:="password"
Beep
ActiveSheet.Protect
ActiveSheet.Protect Password:="password"
End Sub

Dopo l'esecuzione il foglio e' protetto ma senza password

Prova a rimuovere la protezione subito prima di applicarla con password, come in questo esempio
Codice: Seleziona tutto
Sub miooo22()
ActiveSheet.Unprotect Password:="password"
Beep
ActiveSheet.Protect
ActiveSheet.Unprotect Password:="password"        '+++ LINEA AGGIUNTA
ActiveSheet.Protect Password:="password"
End Sub

Fai sapere...
Avatar utente
Anthony47
Moderatore
 
Post: 19387
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Macro protezione foglio con password non funge

Postdi xilofono » 23/01/24 17:25

:aaah non ci avevo fatto caso!!!
Quella macro che filtra non la stavo ancora testando e me ne ero scordato completamente, ho settato anche per quella la password

Codice: Seleziona tutto
Private Sub Worksheet_Change(ByVal Target As Range)

'macro per filtrare risultati

Dim i As Long
Dim UR As Long

If Not Intersect(Target, Range("j10:j16")) Is Nothing Then
    UR = 40000
    Application.EnableEvents = False
    ActiveSheet.Unprotect ++++("password")++++
        ActiveSheet.Range("$r$18:$r$" & UR).AutoFilter Field:=1, Criteria1:="<>0"
    ActiveSheet.Protect ++++("password")++++
    Application.EnableEvents = True

End If
End Sub


e ho aggiunto una riga (evidenziata con ++++ ) di rimozione della pass dopo la modifica che fa scattare il Worksheet_Change e tutto torna

Codice: Seleziona tutto
Private Sub Registra_Merce_Click()

 Azione = MsgBox("Verificare i dati inseriti. Procedere?", vbYesNo, "Conferma") 'mex introduzione
If Azione = vbNo Then GoTo finesub




ActiveSheet.Unprotect ("password") 'toglie protezione


Dim myNext As Long 'registra dati
'Application.ScreenUpdating = False
Application.EnableEvents = False
myNext = Sheets("Tracciabilità Carne").Cells(Rows.Count, "b").End(xlUp).Row + 1
Sheets("Tracciabilità Carne").Cells(myNext, "b").Resize(6, 9).Value = Sheets("Tracciabilità Carne").Range("q1:y6").Value

Application.EnableEvents = True
'Application.ScreenUpdating = True
   
 
   
    Range("B3:G8").Select 'pulizia campo compilazione
    Range("G8").Activate
    Selection.ClearContents


    Range("J10:J16").Select 'toglie filtri
    Selection.ClearContents
   
++++++++++++++++++ ActiveSheet.Unprotect ("password") ++++++++++++++++
   
       Range("B19:J40000").Select 'ordina

    ActiveWorkbook.Worksheets("Tracciabilità Carne").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Tracciabilità Carne").Sort.SortFields.Add Key:= _
        Range("B19:B40000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    ActiveWorkbook.Worksheets("Tracciabilità Carne").Sort.SortFields.Add Key:= _
        Range("C19:C40000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("Tracciabilità Carne").Sort
        .SetRange Range("B18:J40000")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   
    Range("b18").End(xlDown).Select 'seleziona ultima riga colB
   
   
    ActiveSheet.Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True  'protezione foglio
   
     ActiveWorkbook.Save  'salvataggio

finesub:
    Range("b3").Select 'se non si accetta la macro
   
End Sub


Ora io vorrei fare queste due aggiunte quella relativa al mex di controllo se la cella S14 ha come valore (risultante da una formula contenta nella cella) pari a "No" e alla pass che viene impostata diversamente se si supera una certa data

La seconda credo di esserci riuscito da solo, inserita in coda al codice

Codice: Seleziona tutto
DataOggi = Now()
  If Date > CDate("31/03/2025") Then
    ActiveSheet.Protect Password:="wordpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
End If
 ActiveSheet.Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True


Dovrebbe funzionare in tutti i casi senza errori, spero!

La prima ammetto che non lo so fare
Un tentativo che ho fatto usando una cella di supporto (R14) in cui si incolla il valore risultante della formula di S14
è come se non avessi messo niente

Codice: Seleziona tutto
Private Sub Registra_Merce_Click()

++++++++++

ActiveSheet.Unprotect ("password")
Range("S14").Select
    Selection.Copy
    Range("R14").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

 ActiveSheet.Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True

Range("b3").Select

Cdati = "R14"
If Target = "No" Then
Azione = MsgBox("Dati inseriti errati o incompleti, verificare.", vbOkOk, "Errore") 'mex controllo
If Azione = vbOK Then GoTo finesub
End If

+++++++++++++++

 Azione = MsgBox("Verificare i dati inseriti. Procedere?", vbYesNo, "Conferma") 'mex introduzione
If Azione = vbNo Then GoTo finesub




ActiveSheet.Unprotect ("password") 'toglie protezione


Dim myNext As Long 'registra dati
'Application.ScreenUpdating = False
Application.EnableEvents = False
myNext = Sheets("Tracciabilità Carne").Cells(Rows.Count, "b").End(xlUp).Row + 1
Sheets("Tracciabilità Carne").Cells(myNext, "b").Resize(6, 9).Value = Sheets("Tracciabilità Carne").Range("q1:y6").Value

Application.EnableEvents = True
'Application.ScreenUpdating = True
   
 
   
    Range("B3:G8").Select 'pulizia campo compilazione
    Range("G8").Activate
    Selection.ClearContents


    Range("J10:J16").Select 'toglie filtri
    Selection.ClearContents
   
ActiveSheet.Unprotect ("password")
   
       Range("B19:J40000").Select 'ordina

    ActiveWorkbook.Worksheets("Tracciabilità Carne").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Tracciabilità Carne").Sort.SortFields.Add Key:= _
        Range("B19:B40000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    ActiveWorkbook.Worksheets("Tracciabilità Carne").Sort.SortFields.Add Key:= _
        Range("C19:C40000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("Tracciabilità Carne").Sort
        .SetRange Range("B18:J40000")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   
    Range("b18").End(xlDown).Select 'seleziona ultima riga colB
   

+++++++++++++++
DataOggi = Now()
  If Date > CDate("31/03/2025") Then
    ActiveSheet.Protect Password:="wordpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
End If
 ActiveSheet.Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True
++++++++++++++++

   
     ActiveWorkbook.Save  'salvataggio

finesub:
    Range("b3").Select 'se non si accetta la macro
   
End Sub


file
https://we.tl/t-LU2PyA34xv
Windows 11 - Office 2016 Ita
Avatar utente
xilofono
Utente Junior
 
Post: 80
Iscritto il: 27/11/17 09:52

Re: Macro protezione foglio con password non funge

Postdi xilofono » 23/01/24 19:17

ooops, altra distrazione mia....

Codice: Seleziona tutto
If Target = "No" Then


modificato in


Codice: Seleziona tutto
If Target = No Then


ma non funziona comunque, se la cella non è "No" non parte il resto della macro
Windows 11 - Office 2016 Ita
Avatar utente
xilofono
Utente Junior
 
Post: 80
Iscritto il: 27/11/17 09:52

Re: Macro protezione foglio con password non funge

Postdi Anthony47 » 24/01/24 01:56

Per la password che cambia dopo una certa data, il mio suggerimento:
Codice: Seleziona tutto
If Date > DateSerial(2025, 3, 31) Then
    ActiveSheet.Protect Password:="wordpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
Else
    ActiveSheet.Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True
End If


Quanto al messaggio nel caso che S14 contenga la stringa No, il mio suggerimento
Codice: Seleziona tutto
Private Sub Registra_Merce_Click()
'
ActiveSheet.Unprotect ("password")
If Range("S14") = "No" Then
    Azione = MsgBox("Dati inseriti errati o incompleti" & vbCrLf & _
      "OK se i dati sono corretti; ANNULLA per interrompere per controllare i dati", vbOKCancel, "Errore?")  'mex controllo
    If Azione = vbCancel Then GoTo FINeSub
End If

Dim myNext As Long 'registra dati
'
' continua il corpo principale della macro
' Il foglio E' SPROTETTO, NON PROTEGGERLO SE NON NEI 2 POSTI aaa E bbb
'
'
'
ActiveSheet.Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True   'aaa
ActiveWorkbook.Save  'salvataggio
FINeSub:
ActiveSheet.Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True   'bbb
Range("b3").Select 'se non si accetta la macro
End Sub


ooops, altra distrazione mia....
Codice: Seleziona tutto
    If Target = "No" Then


modificato in
Codice: Seleziona tutto
    If Target = No Then


La formulazione giusta e' "No", ma non capisco cosa sia "Target": in una macro normale (non relativa alla gestione di qualche Evento) Target e' una variabile come qualsiasi altra.
Quindi If Target = "No" sara' ragionevolmente sempre Falso; e If Target = No ragionevolmente sempre Vero (perche' la variabile Target mai inizializzata sara' sempre uguale alla variabile No anche lei mai inizializzata)

Ciao
Avatar utente
Anthony47
Moderatore
 
Post: 19387
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Macro protezione foglio con password non funge

Postdi xilofono » 27/01/24 15:31

:oops: Grazie!

Ora la faccio girare così funziona perfettamente

Codice: Seleziona tutto
Private Sub Registra_Merce_Click()

    ActiveWorkbook.Protect Password:="password", Structure:=True, Windows:=False
   
ActiveSheet.Unprotect ("password") 'toglie protezione



 If Range("S14") = "No" Then
    Azione = MsgBox("Dati inseriti errati o incompleti, verificare.", vbOKOnly, "Errore") 'mex controllo
 If Azione = vbOK Then GoTo finesub
End If

If Range("b3") < Range("s16") Then
    Azione = MsgBox("La data è precedente a oggi. Confermare?", vbYesNo, "Inserimento retroattivo") 'mex controllo
 If Azione = vbNo Then GoTo finesub
End If

 Azione = MsgBox("Verificare i dati inseriti. Procedere?", vbYesNo, "Conferma") 'mex introduzione
If Azione = vbNo Then GoTo finesub

 Range("A1").Select
    ActiveCell.FormulaR1C1 = ""
    Range("A2").Select

Dim myNext As Long 'registra dati
'Application.ScreenUpdating = False
Application.EnableEvents = False
myNext = Sheets("Tracciabilità Carne").Cells(Rows.Count, "b").End(xlUp).Row + 1
Sheets("Tracciabilità Carne").Cells(myNext, "b").Resize(6, 10).Value = Sheets("Tracciabilità Carne").Range("q1:z6").Value

Application.EnableEvents = True
'Application.ScreenUpdating = True
   
 
   
    Range("B3:h8").Select 'pulizia campo compilazione
    Range("G8").Activate
    Selection.ClearContents


    Range("J10:J17").Select 'toglie filtri
    Selection.ClearContents
   
    ActiveSheet.Unprotect ("password")
   
       Range("B21:Jk40000").Select 'ordina

    ActiveWorkbook.Worksheets("Tracciabilità Carne").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Tracciabilità Carne").Sort.SortFields.Add Key:= _
        Range("B21:B40000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    ActiveWorkbook.Worksheets("Tracciabilità Carne").Sort.SortFields.Add Key:= _
        Range("C21:C40000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("Tracciabilità Carne").Sort
        .SetRange Range("B20:k40000")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
   
    Range("b20").End(xlDown).Select 'seleziona ultima riga colB
   
       
finesub: 'se non si accetta la macro va dritto qui
   
      If Date > DateSerial(2025, 3, 31) Then 'protezione foglio
       ActiveSheet.Protect Password:="wordpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
Else
    ActiveSheet.Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True
End If

    Range("b3").Select
   
    ActiveWorkbook.Save  'salvataggio

   
End Sub


Vorrei inoltre condividere questo codice che sicuramente è già girato nel forum, io l'ho trovato sul web non qui: sostanzialmente salvagarda la formattazione condizionale delle celle libere, annoso problema dei fogli di lavoro usati da più persone su uno stesso pc.
Praticamente rende possibile solo la funzione incolla valori, quando si copia un'altra cella (libera o protetta con possibilità di selezione) basta cliccare col sinistro o col destro del mouse sulla cella in cui si vuole copiare il contenuto e si applica l'incolla valori.

Per farla girare va messa in "Questa cartella di lavoro" non su un modulo nè nel codice di un singolo foglio

Codice: Seleziona tutto
rivate Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

    'consente solo copia valori
   
    On Error Resume Next
    Target.PasteSpecial xlPasteValues
    Application.CutCopyMode = True
   
   
End Sub
Windows 11 - Office 2016 Ita
Avatar utente
xilofono
Utente Junior
 
Post: 80
Iscritto il: 27/11/17 09:52

Re: Macro protezione foglio con password non funge

Postdi Anthony47 » 27/01/24 23:10

Un warning sul codice pubblicato per consentire solo Incolla-speciale/Valori: dopo aver "Copiato" l'origine, l'incolla avverra' sulla prima cella che viene selezionata; quindi mi raccomando: cautela, mano ferma e non cliccare nessuna cella se non la destinataria finale

Io in genere uso questa, da inserire nel modulo Vba del foglio da "proteggere":
Codice: Seleziona tutto
Private Sub Worksheet_Change(ByVal Target As Range)
'Forza Copia /Valori
Dim CkArea As String, mArr
'
CkArea = "A5:P22"           '<<< Eventuale area a cui limitare l'azione      <<<AA
If Application.Intersect(Target, Range(CkArea)) Is Nothing Then Exit Sub    '<<<BB
'
Application.EnableEvents = False
On Error Resume Next
    mArr = Target.Value
    Application.Undo
    Target.Value = mArr
If Err.Number <> 0 Then
    Application.Undo
    Err.Clear
End If
Application.CutCopyMode = False
On Error GoTo 0
Application.EnableEvents = True
End Sub

Le prime due istruzioni, marcate <<<AA e <<<BB, servono per eventualmente restringere l'area su cui si vuole limitare il Copia-Valori; ovviamente la riga AA va compilata con l'area di restrizione. Se si vuole applicare la restrizione a tutto il foglio, eliminare ambedue le righe AA e BB

Ciao
Avatar utente
Anthony47
Moderatore
 
Post: 19387
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Macro protezione foglio con password non funge

Postdi xilofono » 28/01/24 13:03

Sì in fase di lavoro sulla cartella quella macro (quella che ho postato) va assolutamente disabilitata perchè rende troppo difficoltoso operare e sicuramente si sbaglia

Va bene solo ed esclusivamente per file terminati, protetti da pass e che sono destinati a data entry in poche celle modificabili, come appunto nel mio caso, in cui peraltro le celle modificabili sono quasi tutte soggette a convalida dati quindi una copia casuale restituisce errore.
Inoltre per impedire di cambiare le formattazioni condizionali, sempre a foglio terminato, è utile impedire la funzione di trascinamento.

---


Aggiungo questo codice collegato a un pulsante nel foglio di origine, che mi copia i valori presenti in B:J a partire dalla riga 21 (più la riga 20 di intestazione) se appartengono all'anno precedente (date in colonna B) in un nuovo foglio che prende la denominazione dell'anno precedente
Poi nel foglio di origine cancella i valori copiati (a parte gli ultimi tre mesi dell'anno precedente tenuti come base di continuità ed esclusa la riga di intestazione), cancellando anche una colonna in più che indica la data di registrazione della riga e che non era necessario copiare nel nuovo foglio

Il codice funziona perfettamente, anche se sicuramente può essere scritto meglio, ma essendo una cosa che va fatta una volta l'anno poco importa.

In testa ho messo un controllo che impedisce di attivare la macro se non si è raggiunto il 31 marzo del corrente anno (anno è preso dalla data odirna, presente in cella S16)

vorrei aggiungere un secondo if, che impedisce di attivare la macro se nel file è già presente un foglio denominato come il valore presente nella cella s17 (che contiene [=anno(oggi())-1] , quindi ad ora 2023)

ma non so come fare
una cosa così

+++++ IF nel file è presente un foglio denominato =Range("s17") Then GoTo finesub +++++++++

Codice: Seleziona tutto
Sub Archivia()

If Date < DateSerial(Year(Range("S16")), 3, 31) Then GoTo finesub
 
+++++ IF   nel file è presente un foglio denominato =Range("s17")   Then GoTo finesub    +++++++++

ActiveSheet.Unprotect ("password")
   ActiveWorkbook.Unprotect ("password")
     
Sheets("Tracciabilità Carne").Select
Dim sel As Range
Dim i As Long
For i = 21 To Range("A" & Rows.Count).End(xlUp).Row
    If Cells(i, 2) < DateSerial(Year(Range("S16")), 1, 1) Then
        If sel Is Nothing Then
            Set sel = Union(Cells(i, 2), Cells(i, 3), Cells(i, 4), Cells(i, 5), Cells(i, 6), Cells(i, 7), Cells(i, 8), Cells(i, 9), Cells(i, 10))
                Else
                  Set sel = Union(sel, Cells(i, 2), Cells(i, 3), Cells(i, 4), Cells(i, 5), Cells(i, 6), Cells(i, 7), Cells(i, 8), Cells(i, 9), Cells(i, 10), Range("b20:j20"))
                End If
    End If
Next
sel.Select
Set sel = Nothing

         
     selection.Copy
     
     
   
       Dim szNomeFoglio As String
       szNomeFoglio = Range("s17")
       On Error GoTo MakeSheet
    Sheets(szNomeFoglio).Activate
        Exit Sub
MakeSheet:
    Sheets.Add , Worksheets(Worksheets.Count)
    ActiveSheet.Name = szNomeFoglio
   
       
    Range("B2").Select
         
         
          Columns("B:B").Select
    selection.NumberFormat = "ddd dd/mm/yyyy"
         
    Columns("A:A").ColumnWidth = 2
    Columns("B:B").EntireColumn.AutoFit
    Columns("C:C").EntireColumn.AutoFit
    Columns("D:D").EntireColumn.AutoFit
    Columns("E:E").EntireColumn.AutoFit
    Columns("F:F").ColumnWidth = 70
    Columns("G:G").ColumnWidth = 25
    Columns("H:H").ColumnWidth = 40
    Columns("I:I").EntireColumn.AutoFit
    Columns("L:L").EntireColumn.AutoFit
    Columns("j:j").EntireColumn.AutoFit
    Columns("k:k").ColumnWidth = 2
   
   
    Range("B2:J40000").Select
    ActiveSheet.ListObjects.Add(xlSrcRange, Range("$B$2:$J$40000"), , xlYes).Name = _
        "TabellaRegistrazione"
       
         Columns("B:B").Select
    ActiveSheet.Unprotect
    selection.Font.Bold = True
    Columns("D:D").Select
    selection.Font.Bold = True
    Columns("J:J").Select
    selection.Font.Bold = True
   
     Range("a3").Select
    ActiveWindow.FreezePanes = False
    ActiveWindow.FreezePanes = True
   
     ActiveSheet.ListObjects("TabellaRegistrazione").ShowTableStyleRowStripes = _
        False
       
         Cells.Select
    ActiveSheet.Unprotect
    With selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
   
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFiltering:=True
       
       
        Range("b3").Select
        Sheets("Tracciabilità Carne").Select
                 
               
       
Dim sele As Range
Dim y As Long
For y = 21 To Range("A" & Rows.Count).End(xlUp).Row
    If Cells(y, 2) < DateSerial((Year(Range("S16")) - 1), 10, 1) Then
        If sele Is Nothing Then
            Set sele = Union(Cells(y, 2), Cells(y, 3), Cells(y, 4), Cells(y, 5), Cells(y, 6), Cells(y, 7), Cells(y, 8), Cells(y, 9), Cells(y, 10), Cells(y, 11))
                Else
                  Set sele = Union(sele, Cells(y, 2), Cells(y, 3), Cells(y, 4), Cells(y, 5), Cells(y, 6), Cells(y, 7), Cells(y, 8), Cells(y, 9), Cells(y, 10), Cells(y, 11))
                    End If
    End If
Next
sele.Select
Set sel = Nothing
         
        selection.ClearContents

finesub:

  If Date > DateSerial(2025, 3, 31) Then 'protezione foglio
       ActiveSheet.Protect Password:="wordpass", DrawingObjects:=True, Contents:=True, Scenarios:=True
Else
    ActiveSheet.Protect Password:="password", DrawingObjects:=True, Contents:=True, Scenarios:=True
End If

 ActiveWorkbook.Protect Password:="password", Structure:=True, Windows:=False
 
  ActiveWorkbook.Save

Windows 11 - Office 2016 Ita
Avatar utente
xilofono
Utente Junior
 
Post: 80
Iscritto il: 27/11/17 09:52

Re: Macro protezione foglio con password non funge

Postdi Anthony47 » 28/01/24 15:29

vorrei aggiungere un secondo if, che impedisce di attivare la macro se nel file è già presente un foglio denominato come il valore presente nella cella s17 (che contiene [=anno(oggi())-1] , quindi ad ora 2023)
Ad esempio:
Codice: Seleziona tutto
Dim tSh As Object
On Error Resume Next
    Set tSh = Sheets(Range("S17").Value)
On Error GoTo 0
If Not tSh Is Nothing Then GoTo FINeSub
'
'il tuo codice
'

Nota che, continuando col tuo codice, tSh punta al foglio il cui nome e' in S17, quindi tSh.Select (per esempio) e' lo stesso che dire Sheets(Range("S17").Value).SelectNon so se ti serve...
Avatar utente
Anthony47
Moderatore
 
Post: 19387
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Macro protezione foglio con password non funge

Postdi xilofono » 28/01/24 22:42

esattamente quello è il problema, nel caso ci sia già il foglio, la macro si interrompe (senza dare errore) quando lo punta, selezionandolo
questo già col mio codice, aggiungendo il tuo suggerimento avviene lo stesso

di per sè non sarebbe un problema, se non fosse che quando il ciclo finisce mi lascia la cartella senza protezione della struttura e il foglio di origine senza protezione :x

per rendere l'idea questo è il file ormai finito
https://we.tl/t-OCs9g8c4h6

ci sono 5 soli record per semplicità
la macro in questione è attivata dal pulsante "archivia"

fa il suo lavoro, copia i primi tre record (in quanto appartenenti allo scorso anno) nel nuovo foglio
e poi cancella dal foglio di origine solamente il primo dei tre (in quanto gli altri due fanno parte dell'ultimo trimestre e vanno tenuti) quindi ne rimangono 4

ora se uno ricliccasse "archivia" una seconda volta di per sè non succede niente, tranne che ci si ritrova col foglio 1 (tracciabilità carne) senza protezione e il file senza protezione struttura

non riesco ad impedire che ciò avvenga
(attenzione nella cartella è attiva la macro del forza incolla valori con click, le password sono "password")
speravo fosse possibile fare in modo che se il foglio c'è già si potesse andare a finesub dove sono presenti comandi per riproteggere la struttura della cartella
Windows 11 - Office 2016 Ita
Avatar utente
xilofono
Utente Junior
 
Post: 80
Iscritto il: 27/11/17 09:52

Re: Macro protezione foglio con password non funge

Postdi Anthony47 » 29/01/24 00:48

Non so se c'entra con quello che stai dicendo, ma nel rispondere alla tua richiesta di "aggiungere un secondo if, che impedisce di attivare la macro se nel file è già presente un foglio denominato come il valore presente nella cella s17 (che contiene [=anno(oggi())-1] , quindi ad ora 2023)" mi era sfuggito che la cella S17 contenesse un numero.
Nello "snippet" che t'ho dato va corretta la riga Set tSh come segue:
Codice: Seleziona tutto
Set tSh = Sheets(CStr(Range("S17").Value))


Fai questa modifica e poi aggiornaci...
Avatar utente
Anthony47
Moderatore
 
Post: 19387
Iscritto il: 21/03/06 16:03
Località: Ivrea

Re: Macro protezione foglio con password non funge

Postdi xilofono » 29/01/24 15:36

:oops: con questa modifica, funziona eccome!
anthony non c'è che dire, se c'è un intoppo sei una garanzia
io provo a chiedere il meno possibile fin dove riesco o fin dove reperisco codici da adattare.
grazie mile!
Windows 11 - Office 2016 Ita
Avatar utente
xilofono
Utente Junior
 
Post: 80
Iscritto il: 27/11/17 09:52


Torna a Applicazioni Office Windows


Topic correlati a "Macro protezione foglio con password non funge":


Chi c’è in linea

Visitano il forum: Nessuno e 5 ospiti