Código VBA para copiar dados e gráficos em outra planilha

2024 - VBA & Macros

Post Recente por Fernando Fernandes 7 anos atrás

4 Posts

3 Usuários

0 Reactions

1,062 Visualizações

RSS

Luiz.P

(@luiz-p)

Posts: 1

New Member

Topic starter

Prezados boa noite!
Peguei um código VBA para copiar os dados e colar em outra planilha mantendo a formatação original e somente valores. Isto está funcionando corretamente, o problema é que não esta puxando os gráficos existentes. Alguém sabe como resolver?
O código que estou usando é este:

Sub NovaPastaSemFormulas()
Dim CurrentSheet As Worksheet

Application.ScreenUpdating = False

        'Nome na Planilha Ativa em B1
        nomeB1 = CStr(ActiveSheet.Range("B1").Value)

        Set CurrentSheet = ActiveSheet

        On Error Resume Next

        'copia todas as células da planilha ativa
        CurrentSheet.Cells.Copy
                 
    
        'Cria a Nova PASTA (ARQUIVO)
        Set Wkb = Workbooks.Add


        'cola somente os valores na planilha Ativa da nova Pasta,
        'sem formulas e mantenndo a formatação
        With ActiveSheet.Range("A1")
          .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
          .PasteSpecial Paste:=xlFormats
        
        End With

        Application.CutCopyMode = False

        'Define os Novos Nomes - Planilha(ABA) e Pasta(Arquivo)
        novoNome = nomeB1

        'Renomeia a planilha nova com
        'o Nome que estava em B1
        With ActiveSheet
            .Name = novoNome
            .Range("A1").Select
        End With

        Range("A1").Select

        'Enibe a mensagem se a pasta já existir
        'Com essa instrução a Pasta será substiutida sem questionamento
        Application.DisplayAlerts = False

        'Salva a Nova Pasta no Diretorio abaixo com o mesmo Nome
        'Alterem o mesmo conforme o endereço que querem
        Wkb.SaveAs Filename:="C:" & novoNome & ".xls"
End Sub

Postado : 08/11/2017 7:23 pm

MPrudencio

(@mprudencio)

Posts: 2749

Famed Member

Os graficos seria bem mais simples vc faze-los na nova planilha

Use um range dinamico para ter os dados atualizados.

Marcelo Prudencio
Microsoft Excel Brasil no Facebook

"Começar já é a metade do caminho."
Autor Desconhecido

Simplifica que simples fica.
Nicole Tomazella.

"O Simples é Sempre Melhor Que o Complicado"
Jorge Paulo Lemann.

Postado : 09/11/2017 6:07 pm

Fernando Fernandes

(@fernandofernandes)

Posts: 43750

Illustrious Member

Bom dia!!

Tente assim..

Sub NovaPastaSemFormulas()
Dim CurrentSheet As Worksheet

Application.ScreenUpdating = False
    'Nome na Planilha Ativa em B1
    nomeB1 = CStr(ActiveSheet.Range("B1").Value)
    
    Set CurrentSheet = ActiveSheet
    
    On Error Resume Next
    'copia todas as células da planilha ativa
    CurrentSheet.Cells.Copy
    'Cria a Nova PASTA (ARQUIVO)
    Set Wkb = Workbooks.Add
    'cola somente os valores na planilha Ativa da nova Pasta,
    'sem formulas e mantenndo a formatação
    With ActiveSheet.Range("A1")
        .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .PasteSpecial Paste:=xlFormats
    End With

    Application.CutCopyMode = False
    'Define os Novos Nomes - Planilha(ABA) e Pasta(Arquivo)
    novoNome = nomeB1
    'Renomeia a planilha nova com
    'o Nome que estava em B1
        'copia o gráfico
    Set myChart = CurrentSheet.Shapes("Gráfico 1")
    myChart.Copy
    With ActiveSheet
        .Name = novoNome
        .PasteSpecial Format:="Picture (Enhanced Metafile)", Link:=False, DisplayAsIcon:=False
        .Range("A1").Select
    End With
    'Range("A1").Select
    'Enibe a mensagem se a pasta já existir
    'Com essa instrução a Pasta será substiutida sem questionamento
Application.DisplayAlerts = False
'Salva a Nova Pasta no Diretorio abaixo com o mesmo Nome
'Alterem o mesmo conforme o endereço que querem
Wkb.SaveAs Filename:="C:" & novoNome & ".xls"
End Sub

Att

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

Postado : 10/11/2017 5:45 am