0

Tenho 800 pastas de Excel contendo 1 sheet cada uma, preciso unificar essas sheet em uma única... Preciso apenas das colunas A e B de cada planilha e que ela cole as colunas sempre na próxima coluna livre(Vou ter 1600 "800x2" colunas na sheet unificada)

Alguém tem alguma ideia de como fazer? Tenho essa macro abaixo, porém não consigo fazer ela colar na próxima coluna, ele cola sempre na ultima linha disponível.

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
1
  • Você sabe interpretar o que essa macro está fazendo?? Pq a maioria das linhas comentadas deveriam estar ativas pra que ele funcione e as que não estão comentadas tbm estão com erro. Foi você que comentou? Está assim de propósito?
    – Evilmaax
    24/09/2019 às 23:21

2 Respostas 2

1

Estou na faculdade e agora não vou poder continuar, mas é algo nessa linha:

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

Tenta adaptar aí, se não rolar amanhã dou mais uma mão.

1
  • Para evitar erros, especifique a planilha em Rows.Count, pois a última linha da planilha ativa pode ser retornada se isto não ocorrer, então ficaria: r = shPadrao.Cells(shPadrao.Rows.Count, "A").End(xlUp).Row. Veja esta resposta para outras maneiras. 25/09/2019 às 11:21
0

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

Você deve fazer log-in para responder a esta pergunta.

Esta não é a resposta que você está procurando? Pesquise outras perguntas com a tag .