VBA Excel - Misture o conteúdo de diversas planilhas em uma única planilha - Merge data from all sheets from multiple workbooks and paste them in single worksheet

Termo de Responsabilidade

Quando estamos criando bases de dados que envolvem informações de bases legadas, ou planilhas antigas, onde em alguns casos precisamos juntas informações de centenas de planilhas, saber automatizar esta parte do processo parece ser bem importante.

Se você não for precisar deste código agora, pelo menos deixa essa página guardada nos seus 'Favoritos', certamente a utilizará no futuro.

Caso você deseja copiar os dados a partir de múltiplas planilhas e colá-los numa única e simples planilhas, poderá usar esse código.

Por exemplo, caso você tenha diversas planilhas gravadas numa única pasta, tal como:

a.xlsx

b.xlsx

c.xlsx

d.xlsx

E em cada uma das planilhas você tivesse múltiplas pastas tais como: Jan, Fev, Mar etc., e você precisasse criar uma nova pasta com o nome de "Data". 

Divirta-se

Option Explicit

Option Explicit

Sub merge_multiple_workbooks()

Dim fldpath

Dim fld, fil, FSO As Object

Dim WKB As Workbook

Dim wks As Worksheet

Dim j As Long, w As Long

Dim stcol As String, lastcol As String

stcol = "A" ' Change the starting column of ur data

lastcol = "C" ' Change the ending column of ur data

' SHOW FOLDER DAILOG BOX

With Application.FileDialog(msoFileDialogFolderPicker)

.Title = "Choose the folder"

'.InitialFileName = "c:\"

.Show

End With

On Error Resume Next

fldpath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"

If fldpath = False Then

MsgBox "Folder Not Selected"

Exit Sub

End If

' change sheet names here

Application.ScreenUpdating = False

Application.DisplayAlerts = False

Application.Calculation = xlCalculationManual

Application.StatusBar = True

Application.StatusBar = "Please wait till Macro merge all the files"

Set FSO = CreateObject("scripting.filesystemobject")

Set fld = FSO.getfolder(fldpath)

' browse through all files in source folder

For Each fil In fld.Files

If UCase(Right(fil.Path, 5)) = UCase(".xlsx") And fil.Name <> ThisWorkbook.Name Then

Set WKB = Workbooks.Open(fil.Path)

For Each wks In WKB.Sheets

w = wks.Range("a65356").End(xlUp).Row

' stcol - starting column of my range eg - a

'2 - as my data will start from row 2 because i do not want to copy headers again and again

'lastcol - end column of range eg - c

' w - last filled row in sheet/ ending row of my data

If w >= 2 Then

wks.Range(stcol & "2:" & lastcol & w).Copy _

Destination:=ThisWorkbook.Sheets(1).Range("a65356").End(xlUp).Offset(1, 0)

End If

Next

WKB.Close

End If

Next

MsgBox "Done"

Application.StatusBar = False

Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

Application.DisplayAlerts = True

End Sub

Reference: 

Tags: VBA, Excel, Tips, folder, pasta, diretório, subdiretório, Get, sub folder, names

VBA Excel - Obtendo todos os nomes das subpastas de um diretório - Get Names of all the folders stored in a folder/directory Including Sub folder

Termo de Responsabilidade

Ao efetuar pesquisa de relatório gravados em diversas distintas planilhas, é interessante que saibamos pesquisar o local onde ela esteja. Com este código podemos indicar a apartir de onde a busca inicia.

Sub folder_names_including_subfolder()

Application.ScreenUpdating = False

Dim fldpath

Dim fso As Object, j As Long, folder1 As Object

With Application.FileDialog(msoFileDialogFolderPicker)

.Title = "Choose the folder"

.Show

End With

On Error Resume Next

fldpath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"

If fldpath = False Then

MsgBox "Folder Not Selected"

Exit Sub

End If

Workbooks.Add

Cells(1, 1).Value = fldpath

Cells(2, 1).Value = "Path"

Cells(2, 2).Value = "Dir"

Cells(2, 3).Value = "Name"

Cells(2, 4).Value = "Date Created"

Cells(2, 5).Value = "Date Last Modified"

Set fso = CreateObject("Scripting.FileSystemObject")

Set folder1 = fso.getfolder(fldpath)

get_sub_folder folder1

Set fso = Nothing

Range("a1").Font.Size = 9

ActiveWindow.DisplayGridlines = False

Range("a3:e" & Range("a2").End(xlDown).Row).Font.Size = 9

Range("a2:e2").Interior.Color = vbCyan

Columns("c:h").AutoFit

Application.ScreenUpdating = True

End Sub

Sub get_sub_folder (ByRef prntfld As Object)

Dim SubFolder As Object, subfld As Object, j As Long

For Each SubFolder In prntfld.SubFolders

j = Range("A1").End(xlDown).Row + 1

Cells(j, 1).Value = SubFolder.Path

Cells(j, 2).Value = Left(SubFolder.Path, InStrRev(SubFolder.Path, "\"))

Cells(j, 3).Value = SubFolder.Name

Cells(j, 4).Value = SubFolder.DateCreated

Cells(j, 5).Value = SubFolder.DateLastModified

Next SubFolder

For Each subfld In prntfld.SubFolders

get_sub_folder subfld

Next subfld

End Sub

Reference: 

Tags: VBA, Excel, Tips, folder, pasta, diretório, subdiretório, Get, sub folder, names

VBA Access - Determina se uma pasta ou Diretório existe - Determine if a Folder/Directory Exists or Not

Termo de Responsabilidade

Muitas vezes pode vir a calhar ser capaz de rapidamente determinar se uma Pasta / Diretório existe ou não. 

Abaixo está uma função que faz exatamente isso:

Function IsFolder (sFolder As String) As Boolean

On Error GoTo Error_Handler

    If sFolder = vbnullsring Then GoTo Error_Handler_Exit

   

   If Dir (sFolder, vbDirectory) <> vbNullString Then

        IsFolder = True

    End If

Error_Handler_Exit:

    On Error Resume Next

    Exit Function

Error_Handler:

    If Err.Number &lt;&gt; 52 Then

        MsgBox "The following error has occured" & vbCrLf & vbCrLf & _

           "Error Number: " & Err.Number & vbCrLf & _

           "Error Source: FolderExist" & vbCrLf & _

           "Error Description: " & Err.Description, vbCritical, "An Error has Occured

    End If

    Resume Error_Handler_Exit

End Function

Referências: Devhut.net

Tags: VBA, Access, diretório, pasta, directory, folder, validation, exist

VBA Access - Selecionando o Nó do Treeview - Select the Treeview Root Node.

| Blog Office VBA | Blog Excel | Blog Access |

Ao usar uma Treeview, talvez deseje saber como pode selecionar um nó. Para fazer isso você só precisa usar o seguinte trecho de código.

Me!TreeviewControlName.Nodes(1).Selected = True

A seleção de nós nem sempre produz o resultado desejado. A razão é que, se a classificação for realizada após os nós adicionados, estes talvez não fiquem posicionado na parte superior. Então o que vamos fazer agora? 

Há uma solução, e eu não vou reinventar a roda. UtterAccess tem um banco de dados de amostra com um procedimento chamado GotoFirstNode() que funciona em torno do problema mencionado acima. Também abrange muitas outras funcionalidades e é muito a pena conferir.

Public Function GotoFirstNode (tv As MSComctlLib.TreeView) As MSComctlLib.Node

    Dim nodNode As MSComctlLib.Node

        

    Set nodNode = tv.SelectedItem

    If nodNode Is Nothing And tv.Nodes.Count > 0 Then _

        Set nodNode = tv.Nodes.Item(1)

    

    If tv.Nodes.Count > 0 Then

        Do Until nodNode.Parent Is Nothing

            Set nodNode = nodNode.Parent

        Loop

        Do Until nodNode.Previous Is Nothing

            Set nodNode = nodNode.Previous

        Loop

        

        nodNode.Selected = True

        nodNode.EnsureVisible

    End If

    Set GotoFirstNode = nodNode

End Function

Referências: Utteraccess.com, Devhut.net

Tags: VBA, Access, diretório, pasta, directory, folder, validation

VBA Access - Criando estrutura de Diretórios, Aninhados, Na Rede - Create Directory Structure/Create Multiple Directories/Create Nested Directories

| Blog Office VBA | Blog Excel | Blog Access |

Um dos métodos mais comuns para a criação de diretórios e pastas com o VBA  é usando a instrução MkDir:

MkDir "C:\Bernardes\"

Só que ao se utilizar esta técnica, aprende-se rapidamente as limitações dela. Uma destas é ter de criar uma estrutura de diretório com múltiplas sub-pastas. MkDir só pode criar um diretório num momento, não podendo criar um sub-diretório. 

Assim, supondo que 'C:\Bernardes' não exista, o comando seguinte não iria funcionar e retornará um erro!

MkDir "C:\Bernardes\Luiz"

Se realmente desejar criar essa estrutura usando a instrução MkDir, terá que fazê-lo usando a declaração MkDir duas vezes. Por exemplo:

MkDir "C:\Bernardes"
MkDir "C:\Bernardes\Luiz"

Agora, se você precisa apenas criar 1 ou 2 sub-pasta, talvez o  MkDir ainda seja aceitável, mas há casos em que isso é simplesmente impraticável e outra solução precise ser encontrada. 

Uma possível abordagem pode ser encontrada Criando Diretórios Aninhados (Procure esta solução neste Blog).

Outra abordagem possível é a utilização de uma API simples que pode criar vários diretórios com uma chamada.

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long

Public Sub MakeFullDir (strPath As String)

    If Right(strPath, 1) <> "\" Then strPath = strPath & "\" 'Optional depending upon intent

    MakeSureDirectoryPathExists strPath

End Sub

Ainda outra solução possível, caso alguém queira mexer um pouco mais, seria analisar o caminho do diretório e avaliar o uso da instrução DIR, criando os diretórios onde precisam estar.

Public Sub MyMkDir (sPath As String)

    Dim iStart          As Integer

    Dim aDirs           As Variant

    Dim sCurDir         As String

    Dim i               As Integer

    If sPath <> "" Then

        aDirs = Split(sPath, "\")

        If Left(sPath, 2) = "\\" Then

            iStart = 3

        Else

            iStart = 1

        End If

        sCurDir = Left(sPath, InStr(iStart, sPath, "\"))

        For i = iStart To UBound(aDirs)

            sCurDir = sCurDir & aDirs(i) & "\"

            If Dir(sCurDir, vbDirectory) = vbNullString Then

                MkDir sCurDir

            End If

        Next i

    End If

End Sub

Veja abaixo a descrição de um procedimento chamado MakeMultiStepDirectory. Este é um código esteticamente mais limpo.

Pode ser usado com referência a diretórios e endereços UNC.

Também pode chamar MakeMultiStepDirectory passando o caminho do diretório inteiro e ele vai automaticamente criar todos os diretórios necessários intermediários.

MakeMultiStepDirectory C:\MyApplication\Settings\Templates\VB

A função MakeMultiStepDirectory pode criar diretórios tanto na máquina local (C:\MyApplication\Settings\Templates\VB), uma unidade mapeada ou um compartilhamento de rede UNC (\\BlackCow\MainShare\MyApplication\Settings\Templates\VB). 

Note que a função não pode criar um compartilhamento (Share); o compartilhamento já deve existir e, claro, você deve ter permissões para criar diretórios nele.

A função MakeMultiStepDirectory faz uso do Scripting.FileSystemObject, desse modo o seu projeto vai precisar fazer uma referência à biblioteca Microsoft Scripting Runtime. 

No VBA com seu projeto aberto, vá ao menu Ferramentas, escolha referências e desça até você encontrar o Microsoft Scripting Runtime Library. Marque a caixa próxima a esta entrada.

A função MakeMultiStepDirectory retorna valores que estão listados em Enum um chamado a EMakeDirStatus, definido no módulo. Esta enumeração é como se segue:

     Public Enum EMakeDirStatus

         ErrSuccess = 0

         ErrRelativePath

         ErrInvalidPathSpecification

         ErrDirectoryCreateError

         ErrSpecIsFileName

         ErrInvalidCharactersInPath

     end Enum

Onde

ErrSuccess indica que a operação foi bem sucedida.

ErrRelativePath indica que um caminho relativo foi passado para a função. Você deve passar um caminho absoluto (começando com qualquer letra de unidade ou um nome de compartilhamento UNC.

ErrInvalidPathSpecification indica que o caminho está mal formado.

ErrDirectoryCreateError indica que houve um erro ao criar o diretório. Na maioria das vezes, esta é uma questão de segurança / autorização.

ErrSpecIsFileName indica que o parâmetro de entrada não era um nome de arquivo ou nome de pasta.

ErrInvalidCharactersInPath indica que houve caracteres inválidos no nome da pasta.

O código para MakeMultiStepDirectory é mostrado abaixo.

Private Declare Function PathIsRelative Lib "Shlwapi" _

        Alias "PathIsRelativeA" (ByVal Path As String) As Long

    Public Enum EMakeDirStatus

        ErrSuccess = 0

        ErrRelativePath

        ErrInvalidPathSpecification

        ErrDirectoryCreateError

        ErrSpecIsFileName

        ErrInvalidCharactersInPath

    End Enum

    Const MAX_PATH = 260

    Function MakeMultiStepDirectory (ByVal PathSpec As String) As EMakeDirStatus

    ' MakeMultiStepDirectory

    ' This function creates a series of nested directories. The parent of

    ' every directory is create before a subdirectory is created, allowing a

    ' folder path specification of any number of directories (as long as the

    ' total length is less than MAX_PATH.

    

    Dim FSO As Scripting.FileSystemObject

    Dim DD As Scripting.Drive

    Dim B As Boolean

    Dim Root As String

    Dim DirSpec As String

    Dim N As Long

    Dim M As Long

    Dim S As String

    Dim Directories() As String

        

    Set FSO = New Scripting.FileSystemObject

        

    ' ensure there are no invalid characters in spec.

    On Error Resume Next

    Err.Clear

    S = Dir(PathSpec, vbNormal)

    If Err.Number <> 0 Then

        MakeMultiStepDirectory = ErrInvalidCharactersInPath

        Exit Function

    End If

    On Error GoTo 0

    

    ' ensure we have an absolute path

    B = CBool(PathIsRelative(PathSpec))

    If B = True Then

        MakeMultiStepDirectory = ErrRelativePath

        Exit Function

    End If

    

    ' if the directory already exists, get out with success.

    If FSO.FolderExists(PathSpec) = True Then

        MakeMultiStepDirectory = ErrSuccess

        Exit Function

    End If

    

    ' get rid of trailing slash

    If Right(PathSpec, 1) = "\" Then

        PathSpec = Left(PathSpec, Len(PathSpec) - 1)

    End If

    

    ' ensure we don't have a filename

    N = InStrRev(PathSpec, "\")

    M = InStrRev(PathSpec, ".")

    If (N > 0) And (M > 0) Then

        If M > N Then

            ' period found after last slash

            MakeMultiStepDirectory = ErrSpecIsFileName

            Exit Function

        End If

    End If

    

    If Left(PathSpec, 2) = "\\" Then

        ' UNC -> \\Server\Share\Folder...

        N = InStr(3, PathSpec, "\")

        N = InStr(N + 1, PathSpec, "\")

        Root = Left(PathSpec, N - 1)

        DirSpec = Mid(PathSpec, N + 1)

    Else

        ' Local or mapped -> C:\Folder....

        N = InStr(1, PathSpec, ":", vbBinaryCompare)

        If N = 0 Then

            MakeMultiStepDirectory = ErrInvalidPathSpecification

            Exit Function

        End If

        Root = Left(PathSpec, N)

        DirSpec = Mid(PathSpec, N + 2)

    End If

    Set DD = FSO.GetDrive(Root)

    Directories = Split(DirSpec, "\")

    DirSpec = DD.Path

    For N = LBound(Directories) To UBound(Directories)

        DirSpec = DirSpec & "\" & Directories(N)

        If FSO.FolderExists(DirSpec) = False Then

            On Error Resume Next

            Err.Clear

            FSO.CreateFolder (DirSpec)

            If Err.Number <> 0 Then

                MakeMultiStepDirectory = ErrDirectoryCreateError

                Exit Function

            End If

        End If

    Next N

    MakeMultiStepDirectory = ErrSuccess

    End Function

Pode chamar esse código a partir do seu próprio código da seguinte forma:

Sub AAA()

      Dim Result As EMakeDirStatus

        Let Result = MakeMultiStepDirectory ("C:\One\Two\Three\Four")

        If Result = ErrSuccess Then

            Debug.Print "Success"

        Else

            Debug.Print "Error"

        End If

    End Sub

Referências: Devhut.net, CPearson.com

Tags: VBA, Access, diretório, pasta, directory, folder, validation, exist, MkDir,  API, MakeFullDir, nested, aninhado,