Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Somar linhas e traz...
 
Notifications
Clear all

Somar linhas e trazer total, e depois excluir linhas somadas

 
2024 - VBA & Macros
Post Recente por pulujr 9 anos atrás
5 Posts
2 Usuários
0 Reactions
744 Visualizações
RSS
 pulujr
(@pulujr)
Posts: 0
New Member
Topic starter
 

Boa noite,

Pessoal,coloquei uma planilha em anexo nesse novo topico e queria o auxilio de vocês para criar uma macro onde fosse criado duas linhas acima da linha com os totais( na planilha em anexo ja esta criado uma linha azul e outra amarelo), onde na linha amarela eu iria somar os valores das colunas C e D das celulas que as 3 primeiras letras da coluna B sejam NEG ou OL ,e logo apos somar essas linhas e trazer o valor para a linha amarela que sera criada acima do total ( Ultima linha da planilha), assim que trouxer o valor das linhas amarelas eles devem ser excluidas, e apos a exclusão das linhas amarelas, trazer na linha azul a soma das colunas C e D que restaram acima da linha azul, a planilha nao precisa ter as cores amarelo e azul, coloquei as cores so para tentar explicar melhor. Quando trouxer os valores para a linha amarela, devera apresentar na coluna b o texto " TOTAL OL + NEGOCIADOS", e na coluna a o mesmo texto " REDE X", e na coluna B da Linha Azul trazer o texto " Total" e na coluna A o texto "REDE X".

 
Postado : 16/06/2015 8:11 pm
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Bom dia!!

Tente algo assim..

Option Explicit

Sub AleVBA_16244()
    Dim lastrow As Long
    lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    Application.ScreenUpdating = False
        With Worksheets("Plan1").Range("$A$1")
            .AutoFilter field:=1, Criteria1:=Array("Total OL + Negociados", "Totais", "Total"), Operator:=xlFilterValues
            .Resize(Rows.Count - 1).Offset(1).EntireRow.Delete
        End With
        ActiveSheet.AutoFilterMode = False
    
        [E1].Value = "AleVBA"
        [F1].Value = "Total OL + Negociados"
        [J1].Value = "Total"
        [N1].Value = "Totais"
        Range("E2").Formula = "=IF(OR(LEFT(B2,3)=""NEG"",LEFT(B2,2)=""OL""),1,0)"
        Range("E2").AutoFill Destination:=Range("E2:E" & lastrow)
        Range("E2:E" & lastrow).Value = Range("E2:E" & lastrow).Value
            With Worksheets("Plan1")
            'Total OL + Negociados
                .Range("A1:E" & lastrow).AutoFilter field:=5, Criteria1:=1
                [I1].Formula = "=SUBTOTAL(9,R2C4:R1000C4)"
                [I1].Value = [I1].Value
                .AutoFilterMode = False
            'Total
                .AutoFilterMode = False
                .Range("A1:E" & lastrow).AutoFilter field:=5, Criteria1:=0
                [M1].Formula = "=SUBTOTAL(9,R2C4:R1000C4)"
                [M1].Value = [M1].Value
                .AutoFilterMode = False
            'Totais
                [Q1].Formula = "=SUM(D:D)"
                [Q1].Value = [Q1].Value
                'Prepara os totais e subtotais
                .Range("F1:I1").Copy Destination:=.Range("A60000").End(xlUp).Offset(1, 0)
                .Range("J1:M1").Copy Destination:=.Range("A60000").End(xlUp).Offset(1, 0)
                .Range("N1:Q1").Copy Destination:=.Range("A60000").End(xlUp).Offset(1, 0)
                .Columns("E:Q").EntireColumn.Delete
            End With
    Application.ScreenUpdating = True
End Sub
 
Postado : 19/06/2015 8:27 am
 pulujr
(@pulujr)
Posts: 0
New Member
Topic starter
 

Boa noite,

Alexandre, isso mesmo que estava procurando, gostaria apenas de mais uma ajuda, que ao final do codigo as linhas que estao de amarelo ( que sao as que possuem as palavras "NEG" ou "OL" fossem deletas ou ocultadas da planilhas, tentei acrescentar algo aqui no código, mas nada deu certo, sera que poderia me auxiliar nesse restante, desde ja muito obrigado, ja me ajudou bastante.

 
Postado : 19/06/2015 9:29 pm
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Bom dia!!

Veja se isso ajuda.

Option Explicit

Sub AleVBA_16244V2()
    Dim lastrow As Long
    lastrow = Cells(Rows.Count, "A").End(xlUp).Row
    Application.ScreenUpdating = False
        With Worksheets("Plan1").Range("$A$1")
            .AutoFilter field:=1, Criteria1:=Array("Total OL + Negociados", "Totais", "Total"), Operator:=xlFilterValues
            .Resize(Rows.Count - 1).Offset(1).EntireRow.Delete
        End With
        ActiveSheet.AutoFilterMode = False
        [E1].Value = "AleVBA"
        [F1].Value = "Total OL + Negociados"
        [J1].Value = "Total"
        [N1].Value = "Totais"
        Range("E2").Formula = "=IF(OR(LEFT(B2,3)=""NEG"",LEFT(B2,2)=""OL""),1,0)"
        Range("E2").AutoFill Destination:=Range("E2:E" & lastrow)
        Range("E2:E" & lastrow).Value = Range("E2:E" & lastrow).Value
            With Worksheets("Plan1")
            'Total OL + Negociados
                .Range("A1:E" & lastrow).AutoFilter field:=5, Criteria1:=1
                [I1].Formula = "=SUBTOTAL(9,R2C4:R1000C4)"
                [I1].Value = [I1].Value
                '
                .AutoFilterMode = False
            'Total
                .AutoFilterMode = False
                .Range("A1:E" & lastrow).AutoFilter field:=5, Criteria1:=0
                [M1].Formula = "=SUBTOTAL(9,R2C4:R1000C4)"
                [M1].Value = [M1].Value
                .AutoFilterMode = False
            'Totais
                [Q1].Formula = "=SUM(D:D)"
                [Q1].Value = [Q1].Value
                'Prepara os totais e subtotais
                .Range("F1:I1").Copy Destination:=.Range("A60000").End(xlUp).Offset(1, 0)
                .Range("J1:M1").Copy Destination:=.Range("A60000").End(xlUp).Offset(1, 0)
                .Range("N1:Q1").Copy Destination:=.Range("A60000").End(xlUp).Offset(1, 0)
                'Deleta as linhas em Amarelo
                With Columns("E")
                    .AutoFilter field:=1, Criteria1:=1
                    .Resize(Rows.Count - 1).Offset(1).EntireRow.Delete
                End With
                .Columns("E:Q").EntireColumn.Delete
            End With
    Application.ScreenUpdating = True
End Sub
 
Postado : 22/06/2015 5:40 am
 pulujr
(@pulujr)
Posts: 0
New Member
Topic starter
 

Muito Obrigado Alexandre, resolveu meu problema. valeu mesmo.

 
Postado : 22/06/2015 5:50 pm
Forum Jump:
  Tópico Anterior
Próximo Tópico