Este fórum está sendo desativado

[luizhalmeida]

Boa tarde a todos!

Precisei reabrir um tópico que está trancado: http://gurudoexcel.com/forum/viewtopic. ... 741#p41741

Ao executar a macro:

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 Abs(Cells(Lin, Col).Value) > 0 Then Exit For             'Cells(Lin, Col).Value = "" Or
            If Col = 2 And Cells(Lin, Col).Value = "" Then Exit For     'Não apaga linha de Centro de Custo
        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)
        Aux1 = "Centro de Custo:"
        If Left(Texto, Len(Aux1)) = Aux1 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

O seguinte erro aparece... http://prntscr.com/mtqabp
Anexo a este post está o arquivo original extraído do sistema e o arquivo após a execução da macro.

Desde já, muito obrigado!

[Jimmy]

Luiz,

Teste com a macro abaixo. Mudei o critério de encontrar uma troca de Centro de Custo.

Jimmy San Juan

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:    LinCC2 = 0    'Linhas do Centro de Custo, a Certa e a Candidata
    CCAnt = "":   CCAtu = ""    'Centros de custos anterior e atual
    Lin = 0
    For Aux1 = 1 To Ate
        Lin = Lin + 1
        Cells(Lin, "A").Select
        If Left(Trim(Cells(Lin + 1, "A").Value), 4) = "2648" And LinCC = 0 Then LinCC = Lin 'Primeiro local de CC
        If Left(Trim(Cells(Lin, "A").Value), 16) = "Centro de Custo:" Then
            CCAtu = Cells(Lin, "A").Value
            If CCAtu = CCAnt Then
                Cells(LinCC, "A").Value = CCAtu
                If LinCC2 > 0 Then Rows(LinCC2).Delete: Lin = Lin - 1
                LinCC2 = Lin 'Como não se sabe se o próximo CCAtu é igual ou não ao anterior, reserva a linha
            Else
                If CCAnt <> "" Then
                    If LinCC2 > 0 Then LinCC = LinCC2  'Se há reserva, usar-se-a
                    LinCC2 = Lin                       'Já defini a nova reserva
                    Cells(LinCC, "A").Value = CCAtu
                End If
                CCAnt = CCAtu
            End If
            Rows(Lin).Delete: GoTo Pula1
        End If

        If Application.WorksheetFunction.CountA(Rows(Lin)) = 0 And Lin <> LinCC And Lin <> LinCC2 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 Abs(Cells(Lin, Col).Value) > 0 Then Exit For             'Cells(Lin, Col).Value = "" Or
            If Col = 2 And Cells(Lin, Col).Value = "" Then Exit For     'Não apaga linha de Centro de Custo
        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)
        Aux1 = "Centro de Custo:"
        If Left(Texto, Len(Aux1)) = Aux1 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