Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Criar "Abas&qu...
 
Notifications
Clear all

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,193 Visualizações
RSS
 JokerPot
(@jokerpot)
Posts: 0
New 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: 0
New 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...

 
Postado : 19/09/2017 12:27 pm
 joebsb
(@joebsb)
Posts: 0
New 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....

 
Postado : 19/09/2017 12:59 pm
Forum Jump:
  Tópico Anterior
Próximo Tópico