Os itens estão dispostos num formato de tabela? Se sim, você pode criar uma rotina na Pasta de Trabalho mãe que faz um laço em todas as Pastas de Trabalho, concatena os dados de todos as outras 17 Pastas de Trabalho, em seguida filtra apenas registros únicos.
Para o exemplo abaixo, não se esqueça de adicionar a referência à biblioteca Microsoft ActiveX Data Objects 2.0 ou superior. Considere que as 17 Pastas de Trabalho estão na mesma pasta e a Pasta de Trabalho mestre numa Planilha diferente:
Private Sub Exemplo()
Dim fld As Object
Dim fl As Object
Dim ws As Worksheet
Dim wsResultados As Worksheet
'Considere que as Pastas de Trabalho estão na mesma pasta.
'Mude o caminho da pasta abaixo para o desejado:
Set fld = CreateObject("Scripting.FileSystemObject").GetFolder("c:temp")
Set ws = ThisWorkbook.Sheets.Add
ws.Range("A1:D1") = Array("Campo1", "Campo2", "Campo3", "Campo4")
For Each fl In fld.Files
If Extensão(fl.Name) = "xls" Then
SQL "SELECT * FROM [Plan1$]", ws.Cells(RowLast(ws.Columns("A")), "A").Offset(1), False, False, fl.Path
End If
Next fl
Set wsResultados = Sheets.Add
'A consulta abaixo é para mostrar apenas registros distintos da primeira lista criada:
SQL "SELECT DISTINCT * FROM [" & ws.Name & "$]", wsResultados.Range("A1"), True, True, ThisWorkbook.FullName
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End Sub
Function RowLast(rng As Range) As Long
'Retorna o valor da última linha povoada do intervalo rng
With rng
On Error Resume Next
RowLast = .Find(What:="*" _
, After:=.Cells(1) _
, SearchDirection:=xlPrevious _
, SearchOrder:=xlByColumns _
, LookIn:=xlFormulas).Row
If RowLast = 0 Then RowLast = rng.Cells(1).Row
End With
End Function
Private Function Extensão(s As String) As String
'Retorna extensão de um arquivo em letras minúsculas.
'Pode gerar exceção se arquivo não possuir exceção.
Extensão = LCase(Mid(s, InStrRev(s, ".") + 1))
End Function
Private Sub SQL(sSQL As String, _
Optional rng As Range, _
Optional bTemCabeçalho As Boolean = True, _
Optional bApagarCampos As Boolean = True, _
Optional sWorkbook As String)
'Faz uma consulta SQL e num intervalo, numa Planilha chamada wsTemp.
'Se bTemCabeçalho = True, significa que os cabeçalhos serão gravados no intervalo ou variant de saída.
'Se bApagarCampos = True, o intervalo de largura igual ao número de recordsets de saída serão apagados
'pelo método ClearContents.
'Para funcionar, é necessário adicionar a referência Microsoft ActiveX Data Objects 2.0 ou superior
Dim lng As Long
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
If Val(Application.Version) < 12 Then 'Para Excel 97-2003
cn.ConnectionString = _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & sWorkbook & ";" & _
"Extended Properties=Excel 8.0;"
cn.Open
Else 'Para Excel 2007 ou 2010
cn.ConnectionString = _
"Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & sWorkbook & ";" & _
"Extended Properties=Excel 8.0"
cn.Open
End If
Set rs = cn.Execute(sSQL)
If bApagarCampos Then
rng.Resize(, rs.Fields.Count).EntireColumn.ClearContents
End If
If bTemCabeçalho Then
For lng = 0 To rs.Fields.Count - 1
rng.Offset(, lng) = rs.Fields(lng).Name
Next lng
Set rng = rng.Offset(1)
End If
rng.CopyFromRecordset rs
rs.Close
cn.Close
End Sub
Felipe Costa Gualberto
Microsoft Excel MVP
http://www.ambienteoffice.com.br
Postado : 29/05/2012 8:26 pm