Código protege fórm...
 
Notifications
Clear all

Código protege fórmulas e oculta linhas do intervalo LENTO !

6 Posts
3 Usuários
0 Reactions
1,120 Visualizações
(@luizhcosta)
Posts: 420
Honorable Member
Topic starter
 

Olá, boa tarde.

Estou com uma dificuldade em uma planilha e que me causa grande embaraço em reuniões. Há tempos aqui no fórum consegui 2 códigos que basicamente executam dois procedimentos. Parte do código bloqueia as fórmulas das células para alterações, logo eu passei a inserir títulos de colunas em fórmulas por exemplo ="Resultado do Período", assim esse título não pode ser alterado. Existem outras fórmulas que envolver números também. Como eu disse, funciona bem.

Mas na mesma planilha havia a necessidade de ocultar as linhas de um determinado intervalo que, no resultado de uma fórmula, fosse igual a "0". O intervalo em questão possui nas células uma operação de cálculo, quando o resultado é igual a zero, a linha é ocultada e o contrário se o valor for maior que zero. Também funciona bem.

Cada parte do código foram soluções em tempos distintos, ou seja, primeiro foi resolvido a questão da proteção e depois para ocultar as linhas. Eu tentei "UNIR" os códigos

e até consegui, mas ao longo do tempo percebi que todo os processo passou a demorar muito, quase 3 minutos para ser executado. Como usa-se muito o código, ficou quase impossível usá-lo.

Então estou postando o código completo para que alguém estude e veja se algo pode ser alterado para agilizar esse procedimento. Como disse, isso tem me causado grande embaraço em reuniões, pois o código faz parte de uma consulta e com a demora...algumas pessoas não entendem nada de execel e logo taxam as planilhas de "não presta" ou "não funciona".

Obrigado pela ajuda.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
ActiveSheet.Unprotect Password:="senha"
ActiveSheet.Protect Password:="senha", UserInterfaceOnly:=True
Cells.Locked = False
On Error Resume Next
Set rng = Cells.SpecialCells(xlCellTypeFormulas)
'Set rng = Cells.SpecialCells(XlCellTypeText) 'Text se quiser travar texto

If Err.Number > 0 Then
Set rng = Cells.SpecialCells(xlCellTypeConstants)
Else
Set rng = Union(rng, Cells.SpecialCells(xlCellTypeFormulas))
'Set rng = Cells.SpecialCells(XlCellTypeText)
End If
On Error GoTo 0
If Not rng Is Nothing Then rng.Locked = True
ActiveSheet.Protect Password:="senha", UserInterfaceOnly:=True
' União de 2 códigos
If Target.Address = "$C$7" Or Target.Address = "$N$42" Or Target.Address = "$S$7" Or Target.Address = "$AC$7" Then
'End Sub

'Private Sub Worksheet_Activate()

Application.ScreenUpdating = False
For Each cell In Range("$BW$2:$BW$150")
If cell.Value = 0 Then
cell.EntireRow.Hidden = True
Else
cell.EntireRow.Hidden = False
End If
Next
Application.ScreenUpdating = True
End If
Range("C13").Select
End Sub
 
Postado : 17/01/2016 4:05 pm
(@mprudencio)
Posts: 2749
Famed Member
 

O ideal seria disponibilizar o arquivo junto com o codigo ate pq o codigo esta aparentemente bem limpo.

A principio acho q dividir os codigos deve funcionar melhor e tambem coloca-los a um botao e executa-lo qdo realmente necessario, a principio seria uma solução temporaria ao problema.

Marcelo Prudencio
Microsoft Excel Brasil no Facebook

"Começar já é a metade do caminho."
Autor Desconhecido

Simplifica que simples fica.
Nicole Tomazella.

"O Simples é Sempre Melhor Que o Complicado"
Jorge Paulo Lemann.

 
Postado : 17/01/2016 8:37 pm
(@luizhcosta)
Posts: 420
Honorable Member
Topic starter
 

Olá, MPrudencio

Tem uma curiosidade a respeito do código. A empresa onde trabalho utiliza a versão 2000 do office, no excel o código funciona perfeitamente, sem demora. Acontece que reuniões são feitas em outros lugares onde o excel é mais atual, 2007, 2010, e nesses o código leva uma eternidade para executar.

O que pode estar acontecendo ?

 
Postado : 18/01/2016 7:42 am
(@mprudencio)
Posts: 2749
Famed Member
 

Nao tenho ideia mas como disse so vendo o codigo com o arquivo...

Não da pra colocar o office 2000 em um Note e levar para as reuniões.

Marcelo Prudencio
Microsoft Excel Brasil no Facebook

"Começar já é a metade do caminho."
Autor Desconhecido

Simplifica que simples fica.
Nicole Tomazella.

"O Simples é Sempre Melhor Que o Complicado"
Jorge Paulo Lemann.

 
Postado : 18/01/2016 9:28 am
(@edcronos2)
Posts: 346
Reputable Member
 

olha
pelo que reparei testando umas planilhas antigas para 2003 é que a apresentação de tela é bem mais eficiente
enquanto no 2003 portátil é super rápido no 2010 dá até raiva

essa macro faz mudança na planilha de acordo com a celula que se modifica Target.Address
é um processo que deixa mais lento por causa da interação com o vba " o vba e a planilha tem que trocar comando de maneira frequente"
Union tbm é um processo custoso

pelo visto sua planilha tem varias formulas
mudança de conteudo em planilhas com muitas formulas deixa pesada
For Each cell In Range("$BW$2:$BW$150") tbm vai gerar uma lentidão por causa da interação com a planilha

tentei fazer umas mudanças na macro, mas não tenho a menor ideia se vai funcionar pq teria que ter uma planilha teste e eu tbm não tenho o office 2000

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range, arrayrang()
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    ActiveSheet.Unprotect Password:="senha"
    ActiveSheet.Protect Password:="senha", UserInterfaceOnly:=True
    Cells.Locked = False
    On Error Resume Next
    Set rng = Cells.SpecialCells(xlCellTypeFormulas)
    'Set rng = Cells.SpecialCells(XlCellTypeText) 'Text se quiser travar texto
    If Err.Number > 0 Then
        Set rng = Cells.SpecialCells(xlCellTypeConstants)
    Else
        Set rng = Union(rng, Cells.SpecialCells(xlCellTypeFormulas))
        'Set rng = Cells.SpecialCells(XlCellTypeText)
    End If
    On Error GoTo 0
    If Not rng Is Nothing Then rng.Locked = True
    
    If Target.Address = "$C$7" Or Target.Address = "$N$42" Or Target.Address = "$S$7" Or Target.Address = "$AC$7" Then

        arrayrang = Range("$BW$2:$BW$150")
        For l = 1 To UBound(arrayrang, 1)
            If arrayrang(l, 1) = 0 Then
                Rows(l + 1).EntireRow.Hidden = True
            Else
                Rows(l + 1).EntireRow.Hidden = False
            End If
        Next

        '        For Each cell In Range("$BW$2:$BW$150")
        '            If cell.Value = 0 Then
        '                cell.EntireRow.Hidden = True
        '            Else
        '                cell.EntireRow.Hidden = False
        '            End If
        '        Next
    End If
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub

tbm achei a primeira parte da macro desnecessária no Target mas sem saber como é a planilha e oq é para fazer fica dificil ajudar
boa sorte

 
Postado : 18/01/2016 12:00 pm
(@luizhcosta)
Posts: 420
Honorable Member
Topic starter
 

Edcronos2

Rapaz, sabe aqueles atiradores de faca de espetáculos de circo, onde eles atiram facas em uma mulher ?. Atirar as facas olhando o alvo já é algo bem difícil, imagina quando eles colocam um faixa nos olhos...você é esse cara de olhos vendados. A sua solução (embora sem a planilha) foi simplesmente sensacional. Agradeço imensamente pela grande ajuda.

Um abraço. Obrigado.

 
Postado : 18/01/2016 4:40 pm