Nós primórdios dos vídeos para a internet (lá pra 2006), publiquei um tutorial sobre como unir o dados de várias planilhas em uma só fazendo uma “maracutaia” com SQL para conseguir a façanha. O tutorial foi divido em 3 partes que ainda constam como os vídeos mais assistidos do meu canal no youtube:
Em todos estes anos publicado, um dos pedidos mais frequentes era como estender a proeza a vários arquivos. Por fim, eis um resultado.
Vejam a macro abaixo:
Option Explicit Private Function ListaArquivos(ByVal Caminho As String) As String() 'Atenção: Faça referência à biblioteca Micrsoft Scripting Runtime Dim FSO As New FileSystemObject Dim result() As String Dim Pasta As Folder Dim Arquivo As File Dim Indice As Long ReDim result(0) As String If FSO.FolderExists(Caminho) Then Set Pasta = FSO.GetFolder(Caminho) For Each Arquivo In Pasta.Files Indice = IIf(result(0) = "", 0, Indice + 1) ReDim Preserve result(Indice) As String result(Indice) = Arquivo.Name Next End If ListaArquivos = result ErrHandler: Set FSO = Nothing Set Pasta = Nothing Set Arquivo = Nothing End Function Public Sub UnirTodos() On Error GoTo trata_saida: Application.ScreenUpdating = False Application.DisplayAlerts = False Dim arquivos() As String Dim lCtr As Long, processados As Long arquivos = ListaArquivos(ThisWorkbook.Path) For lCtr = 0 To UBound(arquivos) If ValidaNomeArquivo(arquivos(lCtr)) Then 'Debug.Print arquivos(lCtr) Call UnirAoArquivo(arquivos(lCtr)) processados = processados + 1 End If Next Application.ScreenUpdating = True Application.DisplayAlerts = True MsgBox processados & " arquivos processados" trata_saida: Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Private Function ValidaNomeArquivo(ByVal nomeArquivo As String) As Boolean Dim result As Boolean result = InStr(1, nomeArquivo, ThisWorkbook.Name, vbTextCompare) = 0 If result Then result = result Or Right(nomeArquivo, 4) = ".xls" result = result Or Right(nomeArquivo, 4) = "xlsx" result = result Or Right(nomeArquivo, 4) = "xlsm" End If ValidaNomeArquivo = result End Function Private Sub UnirAoArquivo(ByVal nomeArquivo As String) On Error GoTo trata_erro_uniraoarquivo Dim wb As Workbook, ws As Worksheet, mySheet As Worksheet, rngCopy As Range Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & nomeArquivo, ReadOnly:=True) Set ws = wb.Worksheets(1) Set mySheet = ThisWorkbook.Worksheets(1) 'seleciona a regiao com conteudo Set rngCopy = ws.Range(ws.Cells(2, 1), ws.Cells(ws.UsedRange.Rows.Count, ws.UsedRange.Columns.Count)) 'copia rngCopy.Copy 'cola no destino With mySheet Call .Paste(.Cells(.UsedRange.Rows.Count + 1, 1)) End With wb.Close trata_saida_uniraoarquivo: Set wb = Nothing Set ws = Nothing Exit Sub trata_erro_uniraoarquivo: GoTo trata_saida_uniraoarquivo: End Sub |
Em resumo:
- A macro da chama principal é a UnirTodos
- Ela usa a Sub ListaArquivos (já mostrada aqui no blog) para obter a lista de arquivos que existem na mesma pasta do arquivo com as macros.
- No meio do processo, a Function ValidaNomeArquivo que retorna um Boolean (Verdadeiro/Falso) confere se o arquivo possui uma extensão de Excel válida, neste caso, xls, xlsx e xlsm e também se não é o próprio arquivo.
- Para cada arquivo válido encontrado na lista, a Sub UnirAoArquivo
- A Sub UnirAoArquivo recebe somente o nome do arquivo como parâmetro. Com isso, ela:
- abre o arquivo
- seleciona a primeira planiha deste arquivo (índice 1)
- copia a área ocupada (usando a propriedade UserRange)
- cola o conteúdo na primeira planilha do arquivo corrente (que contém a macro) na primeira linha não ocupada.
O processo é repetido para cada arquivo válido na pasta. A velocidade de execução depende da quantidade de arquivos na pasta e claro, do poder do computador em questão.
Não há requisito para a estrutura do arquivo, ou seja, não é preciso que todas as planilihas tenham a mesma estrutura de colunas e na mesma ordem. Entretanto, esse tipo de união faz mais sentido quanto essa regra é aplicada.
Bom proveito!