Exportar Planilhas em Arquivos – Criar pastas e arquivos

Procv usando VBA
Procv usando VBA
20 de março de 2011
Recibo em Excel e VBA
Recibo em Excel e VBA
27 de março de 2011

Objetivo: Criar pastas e arquivos com base nas planilhas que estão sendo exportadas.

Criado como resposta ao leitor Walter Costa.

Nesta planilha são utilizados vários códigos interessantes em VBA, seleção de pasta, criação de pastas e exportação das planilhas em novos arquivos.

Abaixo o código fonte da planilha:

Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
    "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
    "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
    As Long
Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Public Sub lsSeparar()
    Dim lQtdePlan   As Integer
    Dim lPlanAtual  As Integer
    Dim lCaminho    As String

    gsPasta

    lCaminho = Worksheets(1).Range("H14").Value

    lQtdePlan = Worksheets.Count
    lPlanAtual = 2

    'Loop pelas planilhas
    While lPlanAtual <= lQtdePlan
        'Cria a pasta
        lsCriarPasta (lCaminho & Worksheets(lPlanAtual).Range("B1").Value)
        Worksheets(lPlanAtual).Activate
        lsCriarArquivo lCaminho & Worksheets(lPlanAtual).Range("B1").Value, Worksheets(lPlanAtual).Range("B1").Value
        lPlanAtual = lPlanAtual + 1
    Wend

    Worksheets("Menu").Activate
    MsgBox "Os arquivos foram criados na pasta determinada!"
End Sub

Private Sub lsCriarPasta(ByVal lPasta As String)
    On Error Resume Next
    MkDir lPasta
End Sub

Private Sub lsCriarArquivo(ByVal lCaminho As String, ByVal lArquivo As String)
    Dim lNomeArquivo As String

    Workbooks.Add
    lNomeArquivo = lArquivo & ".xlsm"

    ActiveWorkbook.SaveAs Filename:= _
        lCaminho & "\" & lNomeArquivo _
        , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    Windows("CriarPastasArquivos.xlsm").Activate

    Range("A1:E200").Copy
    Windows(lNomeArquivo).Activate
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Columns("A:E").EntireColumn.AutoFit
    Cells(1, 1).Select
    ActiveWorkbook.Save
    ActiveWorkbook.Close (True)

    Windows("CriarPastasArquivos.xlsm").Activate
End Sub

Public Function gfSelecionarPasta(ByVal vFolder As String, Optional Title As String, Optional hWnd) As String

    Dim bi As BROWSEINFO
    Dim pidl As Long
    Dim folder As String

    folder = String$(255, Chr$(0))

    With bi
        If IsNumeric(hWnd) Then .hOwner = hWnd
        .pidlRoot = 0
        If Title <> "" Then
            .lpszTitle = Title & Chr$(0)
        Else
            .lpszTitle = "Select a Folder" & Chr$(0)
        End If
    End With

    pidl = SHBrowseForFolder(bi)

    If SHGetPathFromIDList(ByVal pidl, ByVal folder) Then
        folder = Left(folder, InStr(folder, Chr$(0)) - 1)
    Else
        folder = ""
    End If

    If Right(folder, 1) <> "\" And Len(folder) > 0 Then folder = folder & "\"

    gfSelecionarPasta = folder

End Function

Public Sub gsPasta()
    Dim lPasta As String

    lPasta = gfSelecionarPasta("C:", "Selecione o local aonde será gravado o arquivo:")

    Cells(14, 8).Value = lPasta
End Sub

Abraço

Marcos Rieper


Clique aqui e leia mais sobre Excel VBA. https://www.guiadoexcel.com.br/vba/ O Guia do Excel foi criado por Marcos Rieper e oferece artigos, dicas, tutoriais e modelos de planilhas prontas. Aqui você encontra tudo sobre Excel, seja de nível básico, intermediário,  avançado e VBA. O Guia do Excel oferece diversos materiais completamente gratuitos para download. Navegue em nosso site e confira! Conheça também a nossa Loja do Excel https://loja.guiadoexcel.com.br/
Cursos

Curso Excel Completo – Curso Excel Básico + Curso Excel Avançado – Acesso Vitalício

R$218,00 R$179,00

COMPRAR
Cursos

Curso Excel Master – Curso Excel Básico + Curso Excel Avançado + Curso VBA Excel + LP – Acesso Vitalício

R$357,00 R$249,00

COMPRAR
Cursos

Curso Excel PRO – Curso Excel Avançado + Curso VBA Excel + Lógica de programação – Acesso Vitalício

R$258,00 R$199,00

COMPRAR
Cursos

Curso Excel Web – Curso VBA Excel + Lógica de programação + Curso Web Scraping VBA- Acesso Vitalício

R$388,90 R$309,00

COMPRAR

5 Comentários

  1. Walter disse:

    Amigão, muito obrigado pela ajuda que você está me dando, com certeza depois que concluirmos o arquivo, ajudara muitas pessoas nos trabalhos diarios….

    Esse código realmente ficou interessante, aplicado de forma correta em um arquivo, pode ser um sisteminha em excel…

    Abs

  2. Marco disse:

    Meu sistema é 64bits e fica dando erro na “Declare” como resolvo isso?

    • Marcos Rieper disse:

      Bom dia Marco,

      Tem que colocar PtrSafe antes do Function conforme alteração que fiz aqui:

      Public Declare PtrSafe Function SHBrowseForFolder Lib “shell32.dll” Alias _
      “SHBrowseForFolderA” (lpBrowseInfo As BROWSEINFO) As Long
      Public Declare PtrSafe Function SHGetPathFromIDList Lib “shell32.dll” Alias _
      “SHGetPathFromIDListA” (ByVal pidl As Long, ByVal pszPath As String) _
      As Long

      Abraço

      Marcos Rieper

  3. Thiago Luiz disse:

    Olá! Gostaria de saber como utilizar esse código em uma userform criada já com o comando de botão. grato.

Deixe uma resposta

O seu endereço de e-mail não será publicado. Campos obrigatórios são marcados com *

Esse site utiliza o Akismet para reduzir spam. Aprenda como seus dados de comentários são processados.

Inscreva-se no nosso canal do Youtube!


Junte-se ao nosso canal do Youtube. Começamos em abril de 2016, mas já temos mais de 06:00 h de treinamentos gratuitos e este número irá aumentar. Vídeos novos todos os sábados.