Claudinei para Ocultar as Linhas que se referiu apos a Classificação, substitua a Rotina pela a abaixo, resolvi colocar completa devido aos comentarios que fiz na mesma :
Sub Classifica_RSE()
Dim wsa As Worksheet
Set wsa = Sheets("RSE")
Dim sRange As Range
Dim flin As Long
'Qde de Itens na coluna A
'Precisava de ter uma referencia, e a numeração
'nesta coluna propiciou esta implementação para definir os dados na Coluna G
flin = wsa.Range("A65000").End(xlUp).Row
Dim OCOLLECTION As New Collection 'Cria o Objeto Collection, veja na ajuda do VBA a definição e exemplo
Dim VARVALUE As Variant 'Itens a armazenar
Dim cSort As Collection 'Cada item armazenado em OCOLLECTION
Dim lRowIni As Long 'Linha Inicial, em seu modelo começa na linha 8
Dim sLinRetorno As Long 'Linha para colocar os resultados
Dim sLinInsert 'Linhas a Inserir
Dim sTemp, sTemp1 As Currency 'Define as Variaveis com Valores Moeda
Dim sItem
Dim sValor As Variant
Dim X
lRowIni = 8 'Linha Inicial, em seu modelo começa na linha 8
sLinInsert = 2 'Qde de Linhas a inserir
'Qde de Itens na coluna A + 2
'Conta as Linhas e soma mais 2 para efetuar os lançamentod
sLinRetorno = wsa.Range("A65000").End(xlUp).Row + 2
'Definição do Range
Set sRange = Range("G" & lRowIni & ":G" & flin)
X = 2
On Error Resume Next
'Armazena os valores em OCOLLECTION
For Each VARVALUE In sRange
OCOLLECTION.Add CStr(VARVALUE), CStr(VARVALUE)
X = X + 1
Next
'Classifica os valores em Collection
Set cSort = SortCollection(OCOLLECTION)
Dim sSort
Application.ScreenUpdating = False
sItem = cSort.Count - 1
For Each sSort In cSort
For Each sValor In sRange
If sSort = wsa.Range("G" & lRowIni).Value Then
wsa.Range("B" & lRowIni & ":O" & lRowIni).Copy Destination:=wsa.Cells(sLinRetorno, 2)
sTemp = wsa.Cells(lRowIni, 6)
sLinRetorno = sLinRetorno + 1
sTemp1 = sTemp1 + sTemp
wsa.Cells(sLinRetorno, 1).EntireRow.Insert
End If
lRowIni = lRowIni + 1
Next
lRowIni = 8
wsa.Cells(sLinRetorno, 3).Value = "TOTAL PARA A LOCALIDADE"
wsa.Cells(sLinRetorno, 4).Value = sSort
wsa.Cells(sLinRetorno, 6).Value = sTemp1
wsa.Cells(sLinRetorno, 3).Resize(1, 5).Font.Bold = True
'Enquanto a variavel for menor que 1 insere a linha
'Como definimos acima esta qde como 2, insere somente as duas linhas
'e depois sai darotina ao atingir a qde, redirecionando para o final, ondde ocultamos as linhas
If sItem = 0 Then GoTo Fim
Do Until sLinInsert < 1
wsa.Cells(sLinRetorno, 1).Offset(2, 0).EntireRow.Insert shift:=xlDown
'Move uma linha acima
sLinInsert = sLinInsert - 1
Loop
sItem = sItem - 1
sLinInsert = 2
sLinRetorno = sLinRetorno + 2
sTemp1 = 0
Next sSort
Fim:
'Oculta as Linhas
sRange.EntireRow.Hidden = True
End Sub
E na rotina que apaga os lançamentos, utilize a rotina abaixo pra depois que apagar, reexibir as linhas:
Sub Del_Linhas()
Dim sRange As Range
Dim sRowInicio As Long
Dim FinalRow As Long
Dim wsa As Worksheet
Set wsa = Sheets("RSE")
'Verifica a última linha preenchida
FinalRow = wsa.Range("C65536").End(xlUp).Row '- 2
'Linha Inicial, onde se iniciou os lançamentos
sRowInicio = 16
'Verifica antes se tem lançamentos, se não tiver sai da rotina
If wsa.Range("B" & sRowInicio).Value = "" Then
Exit Sub
End If
'Se tiver lançamentos, definimos o Range
Set sRange = wsa.Range("A" & sRowInicio & ":A" & FinalRow)
'Deleta as Linhas
sRange.EntireRow.Delete
'Insere uma linha
wsa.Cells(sRowInicio, 1).EntireRow.Insert
wsa.Range("A" & sRowInicio & ":O" & sRowInicio).Interior.ColorIndex = 2
'Reexibe as linhas
wsa.Range("A8" & ":O" & sRowInicio).EntireRow.Hidden = False
End Sub
Uma sugestão, não querendo alterar o seu projeto, porque não joga o resultado para uma nova aba ?
[]s
Postado : 11/04/2012 7:00 pm