- 27 Fev 2019 às 17:16
#41646
Boa tarde a todos!
Link do Tópico original: viewtopic.php?f=12&t=8523&p=39895#p39895
Esse Tópico foi criado para dar continuidade ao mencionado acima, onde foi criado uma macro que organiza vários relatórios consecutivos em planilhas separadas.
Pois bem, reabro esse tópico pois a macro funciona perfeitamente bem quando o relatório original tem mais de um mês. Quando tem apenas um mês ele não elimina as linhas com apenas valores "zero".
Quando executa a macro com apenas "um mês", fica assim: http://prntscr.com/mr115o
Em anexo está um modelo com apenas um mês e um modelo com 12 meses.
Abaixo está a macro utilizada:
Link do Tópico original: viewtopic.php?f=12&t=8523&p=39895#p39895
Esse Tópico foi criado para dar continuidade ao mencionado acima, onde foi criado uma macro que organiza vários relatórios consecutivos em planilhas separadas.
Pois bem, reabro esse tópico pois a macro funciona perfeitamente bem quando o relatório original tem mais de um mês. Quando tem apenas um mês ele não elimina as linhas com apenas valores "zero".
Quando executa a macro com apenas "um mês", fica assim: http://prntscr.com/mr115o
Em anexo está um modelo com apenas um mês e um modelo com 12 meses.
Abaixo está a macro utilizada:
Código: Selecionar todos
Sub AcertaRel()
Char = "#"
'Fase 1 - Apaga colunas e linhas, e acerta Centro de Custo
Range("C:C,E:E,G:G,I:I,K:K,M:M,O:O,Q:Q,S:S,U:U,W:W").Delete Shift:=xlToLeft
Ate = Cells(Rows.Count, "A").End(xlUp).Row
LinCC = 0 'Linha do Centro de Custo
Lin = 0
For Aux1 = 1 To Ate
Lin = Lin + 1
If Left(Trim(Cells(Lin + 1, "A").Value), 4) = "2648" Then LinCC = Lin
If Application.WorksheetFunction.CountA(Rows(Lin)) = 0 And Lin <> LinCC Then
Rows(Lin).Delete: GoTo Pula1
End If
If LinCC = 0 Then 'Ainda estamos no cabeçalho
If Left(Trim(Cells(Lin, "A").Value), 10) = "Conta Cont" Then 'Achou linha de datas
MaxDatCol = Cells(Lin, Columns.Count).End(xlToLeft).Column 'Última coluna de data
Else
Rows(Lin).Delete: GoTo Pula1
End If
End If
If Left(Trim(Cells(Lin, "A").Value), 16) = "Centro de Custo:" And LinCC > 0 Then
Cells(LinCC, "A").Value = Cells(Lin, "A").Value
Rows(Lin).Delete: GoTo Pula1
End If
Lin = Lin + 1
Pula1:
Lin = Lin - 1
Next
'Fase 2 - Apaga linhas com total zero
Ate = Cells(Rows.Count, "A").End(xlUp).Row
Lin = 0
For Aux1 = 1 To Ate
Lin = Lin + 1
For Col = 2 To 13
If Cells(Lin, Col).Value = "" Or _
Abs(Cells(Lin, Col).Value) > 0 Then Exit For
Next
If Col > 13 Then Rows(Lin).Delete: Lin = Lin - 1
Next
'Fase 3 - Formata e põe total
If MaxDatCol = 0 Then
MaxDatCol = 13
MsgBox "A linha de cabeçalho de meses não foi definida pois " & _
"o texto ""Conta Cont"" não foi encontrado na coluna ""A""." & vbCrLf & vbCrLf & _
"A coluna de totais será faita na coluna ""N""."
End If
MaxTotCol = MaxDatCol + 1
Ate = Cells(Rows.Count, "A").End(xlUp).Row
Range(Cells(2, "B"), Cells(Ate, MaxTotCol)).NumberFormat = "#,##0.00"
Range(Cells(1, "B"), Cells(1, MaxDatCol)).ColumnWidth = 11
Cells(1, MaxTotCol).ColumnWidth = 15
Cells(1, MaxTotCol).Value = "Totais"
Cells(1, MaxTotCol).HorizontalAlignment = xlRight
Range(Cells(3, MaxTotCol), Cells(Ate, MaxTotCol)).Value = "=Sum(B3:" & Mid(Columns(MaxDatCol).Address, 2, 1) & "3)"
Range(Cells(1, MaxTotCol), Cells(Ate, MaxTotCol)).Interior.Color = 12632256
'Fase 4 - Cria planilhas para Centros de Custo
Aux1 = Application.DisplayAlerts: Application.DisplayAlerts = False
For Each Plan In Worksheets 'Percorre as planilhas apagando as de gerações passadas
If Left(Plan.Name, 1) = Char Then Plan.Delete
Next
Application.DisplayAlerts = Aux1
Set Base = ActiveSheet
Set Nova = ActiveSheet
Ate = Cells(Rows.Count, "A").End(xlUp).Row
LinIni = 0: CenCus = ""
For Lin = 1 To Ate + 1
Texto = WorksheetFunction.Trim(Cells(Lin, "A").Value)
If Left(Texto, 16) = "Centro de Custo:" Or Lin = Ate + 1 Then
If LinIni <> 0 Then
LinFim = Lin - 1
Sheets.Add 'Inclui nova planilha
ActiveSheet.Name = CenCus 'Renomeia
ActiveSheet.Move After:=Nova 'Posiciona
Set Nova = ActiveSheet
Base.Select: Range(Cells(1, "A"), Cells(1, MaxTotCol)).Copy 'Copia cabeçalho
Nova.Select: Cells(1, 1).Select: ActiveSheet.Paste
Base.Select: Range(Cells(LinIni, "A"), Cells(LinFim, MaxTotCol)).Copy 'Copia conteúdo
Nova.Select: Cells(2, 1).Select: ActiveSheet.Paste
Base.Select: Range(Columns(1), Columns(MaxTotCol)).Copy 'Copia formatação
Nova.Select: Range(Columns(1), Columns(MaxTotCol)).PasteSpecial Paste:=xlPasteFormats
Cells(1, 1).Select
Base.Select: Cells(1, 1).Select: Application.CutCopyMode = False
End If
LinIni = Lin
CenCus = Char & Trim(Mid(Texto, InStr(1, Texto, "-") + 1, 15))
End If
Next
'Fase 5 - Cria planilhas de Resumo
Sheets.Add 'Inclui planilha RESUMO
Set Nova = ActiveSheet
Nova.Move After:=Base 'Posiciona após a planilha total
Cells(1, "A") = "R E S U M O"
Lin = 4
Cells(Lin, "A").Select: Selection.Font.Bold = True: Selection.Value = "CENTROS DE CUSTO"
For Each Plan In Worksheets 'Percorre as planilhas jogando na planilha Resumo
If Left(Plan.Name, 1) = Char Then
Lin = Lin + 1
Nova.Cells(Lin, "A") = Mid(Plan.Cells(2, 1), 18)
Nova.Cells(Lin, "B") = "=Sum('" & Plan.Name & "'!" & Columns(MaxTotCol).Address & ")"
End If
Next
Lin = Lin + 2: Nova.Cells(Lin, "A") = "SOMA"
Nova.Cells(Lin, "B") = "=Sum(B3:B" & Lin - 1 & ")"
Lin = Lin + 1: Nova.Cells(Lin, "A") = "SOMA na planilha """ & Base.Name & """"
Nova.Cells(Lin, "B") = "=Sum('" & Base.Name & "'!" & Columns(MaxTotCol).Address & ")"
Lin = Lin + 2: Nova.Cells(Lin, "A") = "Diferença"
Nova.Cells(Lin, "B") = "=round(B" & Lin - 3 & " - B" & Lin - 2 & ",4)"
Range(Cells(Lin, "A"), Cells(Lin, "B")).Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=ABS($B$" & Lin & ")>=0,0001"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).Font.Bold = True
Selection.FormatConditions(1).Interior.Color = 255
Selection.FormatConditions(1).StopIfTrue = False
Range("B2:N" & Lin - 1).NumberFormat = "#,##0.00"
Nova.Columns("A:B").EntireColumn.AutoFit
Cells(1, 1).Select
Nova.Name = Char & "Resumo": Nova.Select: Cells(1, 1).Select
Set Base = Nothing
Set Nova = Nothing
End Sub
Atenciosamente,
Luiz Henrique Rodrigues de Almeida
Se minha resposta foi útil, não esqueça de agradecer clicando em Obrigado
Luiz Henrique Rodrigues de Almeida
Se minha resposta foi útil, não esqueça de agradecer clicando em Obrigado
