Veja o código a seguir, em que unifica os dados na planilha aberta, na mesma pasta de trabalho em que o código se encontra.
O programa abre todos os arquivos que estão numa pasta, que deve ser selecionada com o msoFileDialogFolderPicker
, ou seja, uma janela interativa é aberta para escolher a pasta.
E as colunas e planilhas que devem ser copiadas devem ser alteradas na seguinte parte do código:
' Definir colunas que devem ser copiadas
Colunas = Array("A", "B", "D")
' Definir os nomes das planilhas, se forem todas as planilhas, deixar vazio ""
NomePlan = Array("Unificar", "Planilha1")
Código
Sub Unificar()
Dim fso As Object
Dim myFolder As String
Dim wb As Workbook
Dim ws As Worksheet, ws_resultado As Worksheet
Dim UltimaLinha As Long, UltimaColuna As Long
Dim Colunas As Variant, c As Variant, r As Variant, NomePlan As Variant
Dim intervalos As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
' Definir colunas que devem ser copiadas
Colunas = Array("A", "B", "D")
' Definir os nomes das planilhas, se forem todas as planilhas, deixar vazio ""
NomePlan = Array("Unificar", "Planilha1")
Set ws_resultado = ThisWorkbook.ActiveSheet
' Escolher Pasta com os arquivos
Set fso = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Escolha a pasta"
.Show
End With
On Error Resume Next
myFolder = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
' Todos os arquivos Excel da pasta
myFile = Dir(myFolder & "*.xls*")
On Error GoTo 0
On Error GoTo CleanExit
' Loop em todos os arquivos Excel
Do While Len(myFile) > 0
Set wb = Workbooks.Open(Filename:=myFolder & myFile)
'Loop em todas as planilhas da pasta de trabalho
For Each ws In wb.Worksheets
'Condicional para verificar se o nome da planilha é o correto
If IsInArray(UCase(ws.Name), NomePlan) Then
With ws
UltimaLinha = .Range(Colunas(0) & ":" & Colunas(UBound(Colunas))).Find("*", , , , xlByRows, xlPrevious).Row
UltimaColuna = ws_resultado.Cells(1, .Columns.Count).End(xlToLeft).Column
'Loop no vetor de colunas que devem ser copiadas
For c = LBound(Colunas) To UBound(Colunas)
Set intervalos = Uniao_intervalos(intervalos, .Range(Colunas(c) & 1 & ":" & Colunas(c) & UltimaLinha))
Next c
'Escreve os dados, caso não ultrapasse o limite de colunas
If UltimaColuna + UBound(Colunas) > .Columns.Count Then
MsgBox "Número máximo de colunas disponíveis atingido."
GoTo CleanExit
Else
For Each r In intervalos.Areas
UltimaColuna = ws_resultado.Cells(1, .Columns.Count).End(xlToLeft).Column
If UltimaColuna = 1 Then UltimaColuna = 0
r.Copy ws_resultado.Cells(1, UltimaColuna + 1)
Next r
Set intervalos = Nothing
End If
End With
End If
Next ws
' Finaliza o Loop
myFile = Dir
wb.Close
Loop
If myFolder = "" Then
GoTo CleanExit 'Se a pasta estiver vazia, sai do programa
End If
'Sair do Programa
CleanExit:
Set fso = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
If wb Is Not Nothing Then wb.Close
'Se houver erro, mostra mensagem
If Err.Description <> "" Then
MsgBox Err.Description, _
vbExclamation + vbOKCancel, _
"Error: " & CStr(Err.Number)
End If
End Sub
Public Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
Dim i
For i = LBound(arr) To UBound(arr)
If UCase(arr(i)) = stringToBeFound Then
IsInArray = True
Exit Function
End If
Next i
IsInArray = False
End Function
Public Function Uniao_intervalos(a As Range, b As Range) As Range
If b Is Nothing Then Exit Function
If a Is Nothing Then Set a = b
Set a = Union(a, b)
Set Uniao_intervalos = a
End Function