Sbloccare celle tramite macro.

Anonimo
2020-04-02T08:42:48+00:00

Ciao,

mi sono accorto che l'inserimento nella macro di un codice per sbloccare/bloccare le celle, mi rallenta notevolmente l'esecuzione della macro stessa:

Public Sub SR_1()

Dim PulR1 As Shape, cPulR1 As Shape, i As Integer

    Const sPassword As String = "MiaPassword"

    Const rPul1 As String = "SR_1"

    Const crPul1 As String = "CR_1"

For i = 0 To 1

    Select Case Range("O1")

        Case Is = i

        Beep

        Exit Sub

    End Select

Next i

    ActiveSheet.Unprotect Password:=sPassword

    With ActiveSheet

        Set PulR1 = .Shapes(rPul1)

        Set cPulR1 = .Shapes(crPul1)

    End With

    With PulR1

        If Range("R2001") = 1 Then

            .Fill.ForeColor.RGB = RGB(244, 176, 132)

            Range("D15") = ""

            Range("R2001") = 0

            Call Escludi_Puntate_Gioco

        Else

            Range("D15") = 1

            Range("R2001") = 1

            .Fill.ForeColor.RGB = RGB(0, 112, 192)

            Call Escludi_Puntate_Gioco

        End If

    End With

    ActiveSheet.Unprotect Password:=sPassword ' <- ripetuta per evitare l'errore

    With cPulR1

        .Fill.ForeColor.RGB = RGB(244, 176, 132)

        Range("R1951") = 1

    End With

    ActiveSheet.Unprotect Password:=sPassword

End Sub

Public Sub Escludi_Puntate_Gioco()

    Dim Rng As Range, Rng2 As Range, rCell As Range, rCell1 As Range

    Dim RngConteggio As Range, RngSomma As Range, RngSomma1 As Range, RngGiallo As Range, RngGiallo1 As Range

    Dim iCtr As Long

    Dim dSum As Double

    Dim dSum1 As Double

    Dim bMatch As Boolean

    Const sPassword As String = "MiaPassword"

    Const sIntervallo As String = "U1:ABU10"

    Const sIntervallo2 As String = "O57:O1307"

    Const sConteggio As String = "R17"

    Const sSomma As String = "R20"

    Const sSomma1 As String = "S23"

    Set Rng = Range(sIntervallo)

    Set Rng2 = Range(sIntervallo2)

    Set RngConteggio = Range(sConteggio)

    Set RngSomma = Range(sSomma)

    Set RngSomma1 = Range(sSomma1)

    Set RngGiallo = Rng.Rows(1).Offset(17)

    Set RngGiallo1 = Rng.Rows(1).Offset(22)

    ActiveSheet.Unprotect Password:=sPassword

    Rng.Offset(17).Rows(1).Interior.Color = vbYellow

    For Each rCell In Rng.Cells

        With rCell

            bMatch = Not IsError(Application.Match(.Value, Rng2, 0))

            If bMatch Then

                Intersect(.EntireColumn, RngGiallo).Interior.Color = RGB(0, 112, 192)

            End If

        End With

    Next rCell

    For Each rCell In Rng.Rows(1).Offset(17).Cells

        With rCell

            If .Interior.Color <> vbYellow Then

                iCtr = iCtr + 1

                dSum = dSum + .Value

            End If

        End With

    Next rCell

    RngConteggio.Value = iCtr

    RngSomma.Value = dSum

    Rng.Offset(22).Rows(1).Interior.Color = vbYellow

    For Each rCell1 In Rng.Cells

        With rCell1

            bMatch = Not IsError(Application.Match(.Value, Rng2, 0))

            If bMatch Then

                Intersect(.EntireColumn, RngGiallo1).Interior.Color = RGB(0, 112, 192)

            End If

        End With

    Next rCell1

    For Each rCell1 In Rng.Rows(1).Offset(22).Cells

        With rCell1

            If .Interior.Color <> vbYellow Then

                dSum1 = dSum1 + .Value

            End If

        End With

    Next rCell1

    RngSomma1.Value = dSum1

    ActiveSheet.Protect Password:=sPassword

End Sub

Ho messo in grassetto tutto ciò che riguarda la password.

Siccome le macro sono molte, ma pressappoco simili alle due postate, nel momento della loro attivazione, il tempo della loro elaborazione quasi raddoppia rispetto a quando non c'era la password.

Cosa c'è che non va?

Vladimiro

Microsoft 365 e Office | Excel | Per la casa | Windows

Domanda bloccata. Questa domanda è stata eseguita dalla community del supporto tecnico Microsoft. È possibile votare se è utile, ma non è possibile aggiungere commenti o risposte o seguire la domanda.

0 commenti

Risposta accettata dall'autore della domanda

Anonimo
2020-04-02T12:50:48+00:00

Ciao Vladimiro,

mi sono accorto che l'inserimento nella macro di un codice per sbloccare/bloccare le celle, mi rallenta notevolmente l'esecuzione della macro stessa:

Public Sub SR_1()

Dim PulR1 As Shape, cPulR1 As Shape, i As Integer

    Const sPassword As String = "MiaPassword"

    Const rPul1 As String = "SR_1"

    Const crPul1 As String = "CR_1"

For i = 0 To 1

    Select Case Range("O1")

        Case Is = i

        Beep

        Exit Sub

    End Select

Next i

    ActiveSheet.Unprotect Password:=sPassword

    With ActiveSheet

        Set PulR1 = .Shapes(rPul1)

        Set cPulR1 = .Shapes(crPul1)

    End With

    With PulR1

        If Range("R2001") = 1 Then

            .Fill.ForeColor.RGB = RGB(244, 176, 132)

            Range("D15") = ""

            Range("R2001") = 0

            Call Escludi_Puntate_Gioco

        Else

            Range("D15") = 1

            Range("R2001") = 1

            .Fill.ForeColor.RGB = RGB(0, 112, 192)

            Call Escludi_Puntate_Gioco

        End If

    End With

    ActiveSheet.Unprotect Password:=sPassword ' <- ripetuta per evitare l'errore

    With cPulR1

        .Fill.ForeColor.RGB = RGB(244, 176, 132)

        Range("R1951") = 1

    End With

    ActiveSheet.Unprotect Password:=sPassword

End Sub

Public Sub Escludi_Puntate_Gioco()

    Dim Rng As Range, Rng2 As Range, rCell As Range, rCell1 As Range

    Dim RngConteggio As Range, RngSomma As Range, RngSomma1 As Range, RngGiallo As Range, RngGiallo1 As Range

    Dim iCtr As Long

    Dim dSum As Double

    Dim dSum1 As Double

    Dim bMatch As Boolean

    Const sPassword As String = "MiaPassword"

    Const sIntervallo As String = "U1:ABU10"

    Const sIntervallo2 As String = "O57:O1307"

    Const sConteggio As String = "R17"

    Const sSomma As String = "R20"

    Const sSomma1 As String = "S23"

    Set Rng = Range(sIntervallo)

    Set Rng2 = Range(sIntervallo2)

    Set RngConteggio = Range(sConteggio)

    Set RngSomma = Range(sSomma)

    Set RngSomma1 = Range(sSomma1)

    Set RngGiallo = Rng.Rows(1).Offset(17)

    Set RngGiallo1 = Rng.Rows(1).Offset(22)

    ActiveSheet.Unprotect Password:=sPassword

    Rng.Offset(17).Rows(1).Interior.Color = vbYellow

    For Each rCell In Rng.Cells

        With rCell

            bMatch = Not IsError(Application.Match(.Value, Rng2, 0))

            If bMatch Then

                Intersect(.EntireColumn, RngGiallo).Interior.Color = RGB(0, 112, 192)

            End If

        End With

    Next rCell

    For Each rCell In Rng.Rows(1).Offset(17).Cells

        With rCell

            If .Interior.Color <> vbYellow Then

                iCtr = iCtr + 1

                dSum = dSum + .Value

            End If

        End With

    Next rCell

    RngConteggio.Value = iCtr

    RngSomma.Value = dSum

    Rng.Offset(22).Rows(1).Interior.Color = vbYellow

    For Each rCell1 In Rng.Cells

        With rCell1

            bMatch = Not IsError(Application.Match(.Value, Rng2, 0))

            If bMatch Then

                Intersect(.EntireColumn, RngGiallo1).Interior.Color = RGB(0, 112, 192)

            End If

        End With

    Next rCell1

    For Each rCell1 In Rng.Rows(1).Offset(22).Cells

        With rCell1

            If .Interior.Color <> vbYellow Then

                dSum1 = dSum1 + .Value

            End If

        End With

    Next rCell1

    RngSomma1.Value = dSum1

    ActiveSheet.Protect Password:=sPassword

End Sub

Ho messo in grassetto tutto ciò che riguarda la password.

Siccome le macro sono molte, ma pressappoco simili alle due postate, nel momento della loro attivazione, il tempo della loro elaborazione quasi raddoppia rispetto a quando non c'era la password.

Cosa c'è che non va?

  • In tutte le tue macro, elimina ogni istanza della protezione e sprotezione dei fogli
  • Nel modulo di codice dell'oggetto Questa_cartella_di_Lavoroincolla il seguente codice:

'=========>>

Option Explicit

Const sPassword As String = "MiaPassword"

'--------->>

Private Sub Workbook_Open()

    Dim SH As Worksheet

    Dim arrFogli As Variant

    Dim Res As Variant

    Const sFogli As String = "Foglio1, Foglio2"         '<<=== Modifica

    arrFogli = Split(sFogli, ",")

    For Each SH In Me.Worksheets

        With SH

            Res = Application.Match(.Name, arrFogli, 0)

            If Not IsError(Res) Then

                .Protect Password:=sPassword, UserInterfaceOnly:=True

            End If

        End With

    Next SH

End Sub

'<<=========

In questo modo, i fogli di interesse saranno protetti e l'utente non sarà in grado di modificare le celle protette, ma il codice può agire come se i fogli non fossero protetti.

Potresti scaricare il mio file di prova Vladimiro20200402.xlsm

===

Regards,

Norman

La risposta è stata utile?

1 persona ha trovato utile questa risposta.
0 commenti

2 risposte aggiuntive

Ordina per: Più utili
Più utili Più recente Meno recente
  1. Anonimo
    2020-04-02T14:59:04+00:00

    Ciao Vladimiro,

    Ciao Norman,

    alla grande!!!

    Ti ringrazio per il cortese riscontro.

    Alla prossima.

    ===

    Regards,

    Norman

    La risposta è stata utile?

    0 commenti
  2. Anonimo
    2020-04-02T13:32:53+00:00

    Ciao Vladimiro,

    mi sono accorto che l'inserimento nella macro di un codice per sbloccare/bloccare le celle, mi rallenta notevolmente l'esecuzione della macro stessa:

    Public Sub SR_1()

    Dim PulR1 As Shape, cPulR1 As Shape, i As Integer

        Const sPassword As String = "MiaPassword"

        Const rPul1 As String = "SR_1"

        Const crPul1 As String = "CR_1"

    For i = 0 To 1

        Select Case Range("O1")

            Case Is = i

            Beep

            Exit Sub

        End Select

    Next i

        ActiveSheet.Unprotect Password:=sPassword

        With ActiveSheet

            Set PulR1 = .Shapes(rPul1)

            Set cPulR1 = .Shapes(crPul1)

        End With

        With PulR1

            If Range("R2001") = 1 Then

                .Fill.ForeColor.RGB = RGB(244, 176, 132)

                Range("D15") = ""

                Range("R2001") = 0

                Call Escludi_Puntate_Gioco

            Else

                Range("D15") = 1

                Range("R2001") = 1

                .Fill.ForeColor.RGB = RGB(0, 112, 192)

                Call Escludi_Puntate_Gioco

            End If

        End With

        ActiveSheet.Unprotect Password:=sPassword ' <- ripetuta per evitare l'errore

        With cPulR1

            .Fill.ForeColor.RGB = RGB(244, 176, 132)

            Range("R1951") = 1

        End With

        ActiveSheet.Unprotect Password:=sPassword

    End Sub

    Public Sub Escludi_Puntate_Gioco()

        Dim Rng As Range, Rng2 As Range, rCell As Range, rCell1 As Range

        Dim RngConteggio As Range, RngSomma As Range, RngSomma1 As Range, RngGiallo As Range, RngGiallo1 As Range

        Dim iCtr As Long

        Dim dSum As Double

        Dim dSum1 As Double

        Dim bMatch As Boolean

        Const sPassword As String = "MiaPassword"

        Const sIntervallo As String = "U1:ABU10"

        Const sIntervallo2 As String = "O57:O1307"

        Const sConteggio As String = "R17"

        Const sSomma As String = "R20"

        Const sSomma1 As String = "S23"

        Set Rng = Range(sIntervallo)

        Set Rng2 = Range(sIntervallo2)

        Set RngConteggio = Range(sConteggio)

        Set RngSomma = Range(sSomma)

        Set RngSomma1 = Range(sSomma1)

        Set RngGiallo = Rng.Rows(1).Offset(17)

        Set RngGiallo1 = Rng.Rows(1).Offset(22)

        ActiveSheet.Unprotect Password:=sPassword

        Rng.Offset(17).Rows(1).Interior.Color = vbYellow

        For Each rCell In Rng.Cells

            With rCell

                bMatch = Not IsError(Application.Match(.Value, Rng2, 0))

                If bMatch Then

                    Intersect(.EntireColumn, RngGiallo).Interior.Color = RGB(0, 112, 192)

                End If

            End With

        Next rCell

        For Each rCell In Rng.Rows(1).Offset(17).Cells

            With rCell

                If .Interior.Color <> vbYellow Then

                    iCtr = iCtr + 1

                    dSum = dSum + .Value

                End If

            End With

        Next rCell

        RngConteggio.Value = iCtr

        RngSomma.Value = dSum

        Rng.Offset(22).Rows(1).Interior.Color = vbYellow

        For Each rCell1 In Rng.Cells

            With rCell1

                bMatch = Not IsError(Application.Match(.Value, Rng2, 0))

                If bMatch Then

                    Intersect(.EntireColumn, RngGiallo1).Interior.Color = RGB(0, 112, 192)

                End If

            End With

        Next rCell1

        For Each rCell1 In Rng.Rows(1).Offset(22).Cells

            With rCell1

                If .Interior.Color <> vbYellow Then

                    dSum1 = dSum1 + .Value

                End If

            End With

        Next rCell1

        RngSomma1.Value = dSum1

        ActiveSheet.Protect Password:=sPassword

    End Sub

    Ho messo in grassetto tutto ciò che riguarda la password.

    Siccome le macro sono molte, ma pressappoco simili alle due postate, nel momento della loro attivazione, il tempo della loro elaborazione quasi raddoppia rispetto a quando non c'era la password.

    Cosa c'è che non va?

    • In tutte le tue macro, elimina ogni istanza della protezione e sprotezione dei fogli
    • Nel modulo di codice dell'oggetto Questa_cartella_di_Lavoroincolla il seguente codice:

    '=========>>

    Option Explicit

    Const sPassword As String = "MiaPassword"

    '--------->>

    Private Sub Workbook_Open()

        Dim SH As Worksheet

        Dim arrFogli As Variant

        Dim Res As Variant

        Const sFogli As String = "Foglio1, Foglio2"         '<<=== Modifica

        arrFogli = Split(sFogli, ",")

        For Each SH In Me.Worksheets

            With SH

                Res = Application.Match(.Name, arrFogli, 0)

                If Not IsError(Res) Then

                    .Protect Password:=sPassword, UserInterfaceOnly:=True

                End If

            End With

        Next SH

    End Sub

    '<<=========

    In questo modo, i fogli di interesse saranno protetti e l'utente non sarà in grado di modificare le celle protette, ma il codice può agire come se i fogli non fossero protetti.

    Potresti scaricare il mio file di prova Vladimiro20200402.xlsm

    ===

    Regards,

    Norman

    Ciao Norman,

    alla grande!!!

    Grazie e alla prossima,

    Vladimiro

    La risposta è stata utile?

    0 commenti