Unify multiple worksheets from different workbooks

Question

I have 800 Excel folders containing 1 sheet each, I need to unify these sheets into a single... I only need the columns A and B of each sheet and that it always paste the columns in the next free column(I will have 1600 "800x2" columns in the unified sheet)

Does anyone have any idea how to do it? I have this macro below, but I can’t get it to stick to the next column, it always sticks to the last line available.

Sub Unificar()

Dim sPath As String, sName As String, fName As String Dim r As Long, rTemp As Long Dim shPadrao As Worksheet

'Para a macro executar mais rápido! With Application .ScreenUpdating = False .DisplayAlerts = False End With 
'A planilha onde serão colados os dados Set shPadrao = Sheets("Unificar")    
'O caminho onde as planilhas que serão lidas estao sPath = "C:\Users------\Desktop\Grupos FTIR BP\DBP\"    
'Descubro o nome do primeiro arquivo a ser aberto sName = Dir(sPath & ".")    
'Faço o loop que le todos os arquivos Do While sName <> "" 

r = shPadrao.Cells(Rows.Count, "A").End(xlUp).Row    

'O caminho + o nome do arquivo a ser aberto fName = sPath & sName    
'Abro o workbook a ser lido Workbooks.Open Filename:=fName, UpdateLinks:=False    
'Descubro sua quantas linhas ele possui rTemp = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row    
'Colo na planilha principal ActiveWorkbook.ActiveSheet.Range("A2:B" & rTemp).Copy shPadrao.Range("A" & r + 1)    
'Fecho o arquivo já lido ActiveWorkbook.Close SaveChanges:=False 

ScapeB:   

'Atualizo a variavel com funcao DIR() que acha o proximo arquivo nao processado sName = Dir()    

Loop    
On Error GoTo 0    
With Application .ScreenUpdating = True .DisplayAlerts = True End With
End Sub

Answer 1

I’m in college and now I won’t be able to continue, but it’s something along those lines:

Sub Unificar()

Dim sPath As String, sName As String, fName As String
Dim r As Long, rTemp As Long
Dim shPadrao As Worksheet

With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

Set shPadrao = Sheets("Unificar")
sPath = "C:\Users\Max\Desktop\teste\"
sName = Dir(sPath & ".")

Do While sName <> ""

r = shPadrao.Cells(Rows.Count, "A").End(xlUp).Row

fName = sPath & sName
Workbooks.Open Filename:=fName, UpdateLinks:=False
rTemp = ActiveWorkbook.ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
ActiveWorkbook.ActiveSheet.Range("A1:B500").Copy
shPadrao.Activate
shPadrao.Range (rTemp + 1)
ActiveWorkbook.Close SaveChanges:=False

ScapeB:

sName = Dir()

Loop
On Error GoTo 0
With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
End Sub

Try to fit in there, if you don’t roll tomorrow I’ll give you another hand.

Answer 2

See the following code, in which unifies the data in the open sheet, in the same workbook where the code is.

The program opens all files that are in a folder, which must be selected with the msoFileDialogFolderPicker, i.e., an interactive window opens to choose the folder.

And the columns and worksheets that must be copied must be changed in the following part of the code:

' 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")

Code

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