Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Exportando planilha...
 
Notifications
Clear all

Exportando planilhas de uma pasta de trabalho

 
2024 - VBA & Macros
6 Posts
1 Usuários
0 Reactions
1,134 Visualizações
RSS
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Já me deparei algumas vezes com a necessidade de salvar uma ou mais planilhas (abas) de uma pasta de trabalho (arquivo do Excel).

No exemplo de código a seguir, o Excel irá criar uma nova pasta (diretório) a partir da pasta que contém o arquivo com a macro para salvar as planilhas exportadas. Serão exportadas todas as planilhas da pasta de trabalho, cujo nome for diferente de MENU.

Segue o código

Sub ExportarPlanilhas()

'Declarar variáveis
Dim stCaminho As String
Dim stNomeArquivo As String
Dim stNomePlanilha As String
Dim stNovaPasta As String

'Capturar o endereço da pasta (diretório) que contém o arquivo
stCaminho = ThisWorkbook.Path

'Definir o nome da nova pasta a ser criada
stNovaPasta = "RELATORIOS"

stCaminho = stCaminho & "" & stNovaPasta

'Criar uma nova pasta, dentro da pasta que contém o arquivo
'chamada RELATORIOS.
'Se a pasta já existir, o código seguirá para a linha seguinte
On Error Resume Next
MkDir stCaminho

'Capturar o nome do arquivo
stNome = ThisWorkbook.Name

'Loop para percorrer as planilhas do arquivo
For Each ws In ThisWorkbook.Worksheets

'Capturar o nome da planilha
stNomePlanilha = ws.Name

'Testar se o nome da planilha é MENU
If stNomePlanilha "MENU" Then

'Se o nome for diferente de MENU, a planilha é movida para um
'novo arquivo do Excel
ws.Move

'O novo arquivo é salvo, no formato do arquivo em uso pelo Excel
'e seu nome é definido como o nome da planilha, seguida do nome do arquivo
ActiveWorkbook.SaveAs _
Filename:=stCaminho & "" & stNomePlanilha & "-" & stNome, _
FileFormat:=ThisWorkbook.FileFormat

'O novo arquivo é fechado
ActiveWindow.Close SaveChanges:=False
End If
Next ws

End Sub

Mas está dando um erro, ele cria a pasta, mas não cria o arquivo do Excel, peço a ajuda de vocês.

Abraços

 
Postado : 22/08/2014 10:31 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Boa tarde!!

use o comando Workbooks.Add para adicionar o novo arquivo!!

Workbooks.Add 
    ActiveWorkbook.SaveAs ("e:excelNomeArquivo.xls")

Att

 
Postado : 22/08/2014 10:40 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Olá Amigo,

Se não for pedir muito, segue a o link da plan.
https://drive.google.com/open?id=0B3vS2 ... authuser=0

Pode por favor fazer nesta plan.

abraços

 
Postado : 22/08/2014 10:43 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Boa tarde!!

Eu sinto em dizer, mas eu não tenho conta na accounts.google.com.

Att

 
Postado : 22/08/2014 10:55 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Olá Amigo,

Segue o link:

https://www.mediafire.com/?7qb46qbaesj5jf6

Desde já eu agradeço.

 
Postado : 22/08/2014 11:03 am
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
Topic starter
 

Bom dia!!

Veja se ajuda...
Faça as adaptações necessarias!

Sub AleVBA_12867()
Dim strFileName As String
Dim wst As Worksheet
Dim var As Variant
Dim varSheets
 
strFileName = "AleVBA_12867"
If Dir("C:UsersAdministradorDownloadsAleVBA_Teste" & strFileName & ".xlsx") = vbNullString Then
  For Each wst In Worksheets
    If wst.Name <> "Menu" Then
      var = var & wst.Name & ", "
    End If
  Next wst
  If Len(var) > 0 Then
    var = Left(var, Len(var) - 2)
    varSheets = Split(var, ", ")
    Sheets(varSheets).Copy
    For Each wst In ActiveWorkbook.Worksheets
      wst.UsedRange.Value = wst.UsedRange.Value
      Application.Goto reference:=wst.Range("a1")
    Next wst
    ActiveWorkbook.SaveAs Filename:="C:UsersAdministradorDownloadsAleVBA_Teste" & strFileName & ".xlsx", _
        FileFormat:=xlOpenXMLWorkbook, _
        CreateBackup:=False
    MsgBox "O " & strFileName & ".xlsx foi criado e salvo dentro C:...", vbInformation, "Salvar Arquivo"
  End If
Else
  MsgBox "O " & strFileName & ".xlsx arquivo já existe dentro de C:...", vbExclamation, "Salvar Arquivo"
End If
Application.CutCopyMode = False
End Sub

Att

 
Postado : 23/08/2014 7:07 am
Forum Jump:
  Tópico Anterior
Próximo Tópico