Formatar relatórios e separar em planilhas [Parte 2]
Enviado: 27 Fev 2019 às 17:16
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