none
Problemas com Lentidão em Planilha por Macros de Cópia e Cola RRS feed

  • Pergunta

  • Olá pessoal,

    estou desenvolvendo um grupo de funções para manipular uma tabela de forma mais otimizada (melhorar a performance do meu trabalho) e dentre essas funções eu criei 2 delas que estão me causando um problemão. Uma é de abrir uma linhas na tabela e a outra é para fechar linhas na tabela. As vezes eu preciso criar espaço entre 2 registros adjacentes ou então tirar espaço e utilizo essas funções, porém após um certo tempo com a planilha aberta e usando as mesmas começa a apresentar uma lentidão absurda e não sei o motivo. Gostaria de alguma ajuda para poder continuar utilizando essas funções criadas. Estou colocando o código das funções abaixo.

    Desde já grato.

    'OK (Atalho: CTRL + A)
    Sub abrirLinhas()
        If ActiveSheet.ProtectContents = True Then
            MsgBox "Planilha Bloqueada!"
        Else
            If ActiveSheet.Name = "Registros" And ActiveCell.row > 5 Then
                Application.ScreenUpdating = False
            
                Dim lin1, lin2, lin3 As Integer
                Dim ant As String
                Dim col1, col2 As String
                col1 = "A"
                col2 = "T"
                ant = Selection.Address
                lin1 = primeiraLinha()                      
                lin2 = segundaLinha()                       
                lin3 = ultimaLinha()                                    
                
                Range(col1 & lin1 & ":" & col2 & lin3).Copy
                Range(col1 & lin2 + 1).Select
                ActiveSheet.Paste                                           
                
                Call limparLinhas(col1, col2, lin1, lin2)
                
                Application.CutCopyMode = False

                Range(ant).Select
                
                Application.ScreenUpdating = True
            End If
        End If
    End Sub

    -------------------------------------------------------------------------------------------------------------------------

    'OK (Atalho: CTRL + SHIFT + A)
    Sub fecharLinhas()
        If ActiveSheet.ProtectContents = True Then
            MsgBox "Planilha Bloqueada!"
        Else
            If ActiveSheet.Name = "Registros" And ActiveCell.row > 5 Then
                Application.ScreenUpdating = False
                
                Dim lin1, lin2, lin3 As Integer
                Dim ant As String
                Dim col1, col2 As String
                col1 = "A"
                col2 = "T"
                ant = Selection.Address
                lin1 = primeiraLinha()                      
                lin2 = segundaLinha()                       
                lin3 = ultimaLinha()                        
                
                If validarFechamentoDeLinha(col1, col2, lin1, lin2) Then
                    Range(col1 & lin2 + 1 & ":" & col2 & lin3).Copy
                    Range(col1 & lin1).Select
                    ActiveSheet.Paste                
                
                    Call limparLinhas(col1, col2, (lin3 - (lin2 - lin1)), 2000)

                    Application.CutCopyMode = False

                    Range(ant).Select
                Else
                    MsgBox "Intervalo Contém Dados!"
                End If
                
                Application.ScreenUpdating = True
            End If
        End If
    End Sub

    -------------------------------------------------------------------------------------------------------------------------

    'OK
    Function primeiraLinha()
        If InStr(1, Selection.Address, ":", vbTextCompare) Then
            primeiraLinha = Int(Replace(Split(Selection.Address, "$")(2), ":", ""))
        Else
            primeiraLinha = ActiveCell.row
        End If
    End Function

    -------------------------------------------------------------------------------------------------------------------------

    'OK
    Function segundaLinha()
        If InStr(1, Selection.Address, ":", vbTextCompare) Then
            segundaLinha = Int(Replace(Split(Selection.Address, "$")(4), ":", ""))
        Else
            segundaLinha = ActiveCell.row
        End If
    End Function

    -------------------------------------------------------------------------------------------------------------------------

    'OK
    Function ultimaLinha()
        Dim ant As String
        Dim col As String
        col = "A"
        ant = Selection.Address
        Range(col & "1048576").Select
        Selection.End(xlUp).Select
        ultimaLinha = ActiveCell.row
        Range(ant).Select
    End Function

    -------------------------------------------------------------------------------------------------------------------------

    'OK
    Function validarFechamentoDeLinha(col1, col2, lin1, lin2)
        If WorksheetFunction.CountA(Range(col1 & lin1 & ":" & col2 & lin2)) = 0 Then
            validarFechamentoDeLinha = 1
        Else
            validarFechamentoDeLinha = 0
        End If
    End Function

    -------------------------------------------------------------------------------------------------------------------------

    'OK
    Sub limparLinhas(col1, col2, lin1, lin2)
        Range(col1 & lin1 & ":" & col2 & lin2).Value = ""
        Range(col1 & lin1 & ":" & col2 & lin2).Interior.ColorIndex = xlNone
    End Sub

    terça-feira, 9 de abril de 2019 18:37

Todas as Respostas