Criar "Abas" para cada Centro de Custo

2024 - VBA & Macros

Post Recente por joebsb 7 anos atrás

3 Posts

2 Usuários

0 Reactions

1,196 Visualizações

RSS

JokerPot

(@jokerpot)

Posts: 132

Estimable Member

Topic starter

Bom Dia!
Por favor, preciso da ajuda de vcs.

Segue planilha de exemplo do que necessito e abaixo um breve explicação.

Na ABA Base, na coluna C existem alguns Centro de Custos e nas outras colunas valores correspondentes aos meses indo até a coluna BP.

Necessito fosse criada uma nova PLANILHA para cada Centro de Custo copiando os dados da ABA BASE, para a planilha do Centro de Custo específico.

Por exemplo:

Na Aba Base as linhas C6:C9 correspondem ao Centro de Custo 10000000.
Neste caso gostaria que fossem copiados B4:BP9 e colado em uma nova planilha salvando a mesma com o nome do Centro de Custo 10000000.

Seguindo o mesmo raciocinio fazer o mesmo com o Cnetro de Custo 20000000, porem desta vez copiando B4:BP5 (Correpondente aos titulos) e B10:BP12 (Correspondentes aos valores) colado em uma nova planilha salvando a mesma com o nome do Centro de Custo 20000000.

Agradeço a ajuda.

EXEMPLO 1.zip

Postado : 19/09/2017 8:28 am

joebsb

(@joebsb)

Posts: 44

Eminent Member

Tá na mão....

Sub copiadados()
anterior = ""
i = 6
s = 6
Do Until Len(Workbooks("EXEMPLO 1.xlsm").Sheets(1).Cells(i, 3).Text) = 0
    If Workbooks("EXEMPLO 1.xlsm").Sheets(1).Cells(i, 3).Text <> anterior Then
        anterior = Workbooks("EXEMPLO 1.xlsm").Sheets(1).Cells(i, 3).Text
        Workbooks.Add
        Workbooks("EXEMPLO 1.xlsm").Sheets(1).Cells.EntireRow(4).Copy
        Workbooks(2).Sheets(1).Cells.EntireRow(4).Insert
        Workbooks("EXEMPLO 1.xlsm").Sheets(1).Cells.EntireRow(5).Copy
        Workbooks(2).Sheets(1).Cells.EntireRow(5).Insert
        s = 6
    End If
'Código criado por Joe em 18/09/2017
'Contato para Freelancer: (61) 99136-3695
    Workbooks("EXEMPLO 1.xlsm").Sheets(1).Cells.EntireRow(i).Copy
    Workbooks(2).Sheets(1).Cells.EntireRow(s).Insert
    i = i + 1
    s = s + 1
    If Workbooks("EXEMPLO 1.xlsm").Sheets(1).Cells(i, 3).Text <> anterior Then
        Workbooks(2).SaveAs Workbooks("EXEMPLO 1.xlsm").Path & "" & anterior & ".xlsx"
        DoEvents
        Workbooks(2).Close
    End If
Loop
End Sub

Se ficou como você queria, não esqueça de marcar essa mensagem como tópico concluído e mandar o TKS....

Abraços...

Espero ter ajudado.

Se ficou como vc queria... não esqueça de marcar essa mensagem como tópico resolvido e mandar um TKS.

Abraços

Postado : 19/09/2017 12:27 pm

joebsb

(@joebsb)

Posts: 44

Eminent Member

Opa Joker.... foi mal.. acho que me confundi com seu post....

Ora vc diz que precisa de novas abas... outra hora vc diz precisar salvar a planilha com o nome específico....

O código anterior, salva um arquivo no computador para cada centro de custo....

Caso o que vc deseja sejam apenas abas.... segue novo código para você...

Sub copiadados2()
anterior = ""
i = 6
s = 6
Do Until Len(Sheets("BASE").Cells(i, 3).Text) = 0
    If Sheets("BASE").Cells(i, 3).Text <> anterior Then
        anterior = Sheets("BASE").Cells(i, 3).Text
        Worksheets.Add After:=Worksheets("BASE")
        Sheets("BASE").Cells.EntireRow(4).Copy
        Sheets(2).Cells.EntireRow(4).Insert
        Sheets("BASE").Cells.EntireRow(5).Copy
        Sheets(2).Cells.EntireRow(5).Insert
        s = 6
    End If
'Código criado por Joe em 18/09/2017
'Contato para Freelancer: (61) 99136-3695
    Sheets("BASE").Cells.EntireRow(i).Copy
    Sheets(2).Cells.EntireRow(s).Insert
    i = i + 1
    s = s + 1
    If Sheets("BASE").Cells(i, 3).Text <> anterior Then
        Sheets(2).Name = anterior
        DoEvents
    End If
Loop
End Sub

Espero ter ajudado...

Se ficou como vc queria não esqueça de marcar a mensagem como resolvida e mandar o tks...

Abraços....

Espero ter ajudado.

Se ficou como vc queria... não esqueça de marcar essa mensagem como tópico resolvido e mandar um TKS.

Abraços

Postado : 19/09/2017 12:59 pm