Exportar Planilhas em Arquivos – Criar pastas e arquivos

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