Excel Copiar dados de planilhas do Excel

[Cfernandes]

Olá, gostaria de uma ajuda em uma macro para que seja consolidados dados de algum determinado lugar de planilhas do Excel em binários.

 

A Macro deve sempre copiar os dados no mesmo lugar nas células de todos os arquivos que estão na pasta e consolidar as informações em uma nova planilha.

 

Anexo os arquivos que possuem a estrutura e a base esperada. Destacado em amarelo os campos que devem ser copiados.

 

Os arquivos que devem ter seus dados copiados possuem a estrutura padrão então não temos como modificar sua estrutura.

Consolidado.zip

[Wendell Menezes]

@Cfernandes Olá,

 

Cole o código abaixo em um módulo da planilha de consolidar, altere a variável "Folder" com o caminho da pasta onde estão os arquivos que serão consolidados e execute a Sub "CONSOLIDATE_FILES".

 

Sub CONSOLIDATE_FILES()

Dim FSO     As Object
Dim Folder  As String
Dim File    As Object
Dim wb      As Workbook

Folder = "C:\Users\PC\Desktop\Consolidado"  'Pasta com os arquivos a serem consolidados)
FR = 35 'Primeira linha a ser copiada

Application.DisplayAlerts = False
Set FSO = VBA.CreateObject("Scripting.FileSystemObject")

For Each File In FSO.GetFolder(Folder).Files
    If InStr(1, LCase(File), ".xls") > 0 And InStr(1, LCase(File), "$") = 0 And File.Name <> ThisWorkbook.Name Then
        Set wb = Workbooks.Open(File, UpdateLinks:=False)
            With wb.Sheets(1)
                For r = 35 To 44
                    LR = LastRow(3) + 1
                    If .Cells(r, 2) <> "" Then
                        ThisWorkbook.Sheets(1).Range("A" & LR) = .Cells(3, 4)
                        ThisWorkbook.Sheets(1).Range("B" & LR) = .Cells(4, 4)
                        .Range(.Cells(r, 2), .Cells(r, 9)).Copy
                        ThisWorkbook.Sheets(1).Range("C" & LR).PasteSpecial xlPasteValues
                    End If
                Next
            End With
        wb.Close False
    End If
Next

End Sub


Function LastRow(ByVal iColumn As Integer) As Long
    LastRow = ThisWorkbook.Sheets(1).Cells(Rows.Count, iColumn).End(xlUp).Row
End Function

 

[Cfernandes]

@Wendell Menezes muito obrigada! Funcionou muito bem!