Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
salvar dados em uma...
 
Notifications
Clear all

salvar dados em uma nova pasta de trabalho (planilha unica)

 
2024 - VBA & Macros
Post Recente por França 6 anos atrás
5 Posts
4 Usuários
0 Reactions
1,094 Visualizações
RSS
 França
(@franca)
Posts: 0
New Member
Topic starter
 

Boa tarde a todos achei um código em um fórum que salva os dados da sua planilha ("pasta de trabalho") em uma planilha totalmente independente...só que ela salva planilha por planilha que estiver na pasta de trabalho.... gostaria de de tirar somente o laço que que salva todas as planilhas... gostaria de salvar a planilha especifica. exemplo: tenho planilha 1, 2, 3 em minha pasta de trabalho e quero salvar somente a 2 e quando salvar em uma pasta independente apagar a a restante ficando somente 1
porque são dois laços um que salva todas as planilhas existentes em planilhas independentes e outra que apaga planilhas 2, 3 da mesma. segue o código desde ja agradeço.

Dim newBook As Workbook
    Dim sheet As Worksheet
    Dim i As Byte
 
    'Desativa os avisos e atualiação da tela
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
 
    For Each sheet In ThisWorkbook.Worksheets
        'cria uma nova pasta de trabalho:
        Set newBook = Application.Workbooks.Add
        'copia a planilha
        sheet.Copy Before:=newBook.Sheets(1)
        'remove as outras
        For i = 2 To newBook.Worksheets.Count
            newBook.Worksheets(2).Delete
        Next i
        'salva o arquivo
        pasta = Application.GetSaveAsFilename
        newBook.SaveAs pasta & ".xlsx"
        newBook.Close
    Next sheet
 
TrataSaida:
    'Reativa os avisos e atualiação da tela
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    'zera as variáveis
    Set newBook = Nothing
    Set sheet = Nothing
    MsgBox "Feito!"
    Exit Sub
TrataErro:
    MsgBox Err.Description, vbCritical, "Erro"
    GoTo TrataSaida
 
Postado : 06/07/2018 11:19 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Movi teu tópico para o local correto que é VBA & Macros, que é o assunto da tua dúvida, pois você havia postado na sala exclusiva par a apresentação dos novos usuários.

[]s

Patropi - Moderador

 
Postado : 06/07/2018 1:29 pm
 Wagner Morel
(@wagner-morel-vidal-nobre)
Posts: 4063
Famed Member
 

França,

Boa noite!

Faça assim:

    Dim newBook As Workbook
    Dim sheet As Worksheet
    Dim i As Byte

    'Desativa os avisos e atualiação da tela
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    For Each sheet In ThisWorkbook.Worksheets
        If sheet.Index = 2 Then
            'cria uma nova pasta de trabalho:
            Set newBook = Application.Workbooks.Add
            'copia a planilha
            sheet.Copy Before:=newBook.Sheets(1)
            'remove as outras
            For i = 2 To newBook.Worksheets.Count
                newBook.Worksheets(2).Delete
            Next i
            'salva o arquivo
            pasta = Application.GetSaveAsFilename
            newBook.SaveAs pasta & ".xlsx"
            newBook.Close
        End If
    Next sheet
    
TrataSaida:
        'Reativa os avisos e atualiação da tela
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        'zera as variáveis
        Set newBook = Nothing
        Set sheet = Nothing
        MsgBox "Feito!"
        Exit Sub
TrataErro:
        MsgBox Err.Description, vbCritical, "Erro"
        GoTo TrataSaida
 
Postado : 06/07/2018 3:05 pm
 MPrudencio
(@mprudencio)
Posts: 0
New Member
 

Se eu entendi este codigo atende

Sub CopiaPlanilha()

Dim Caminho As String

Caminho = "C:Users" & Environ("User Name") & "Desktop" 'Altere o Caminho onde salvar o arquivo

    Sheets("Planilha2").Copy 'Altere o nome da guia de acordo com a necessidade
    ChDir Caminho
    ActiveWorkbook.SaveAs Filename:=Caminho & "Pasta.xlsx"
    ActiveWindow.Close
End Sub
 
Postado : 06/07/2018 4:56 pm
 França
(@franca)
Posts: 0
New Member
Topic starter
 

Obrigado Wagner funcionou perfeitamente

 
Postado : 08/07/2018 7:31 pm
Forum Jump:
  Tópico Anterior
Próximo Tópico