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
