Usando o VBA para mesclar dados de várias pastas de trabalho

Question

Peço desculpas se esta pergunta já tiver sido feita. Eu pesquisei e encontrei apenas uma consulta que está relacionada à minha situação: Como posso mesclar centenas de arquivos de planilha do Excel? .

Eu modifiquei o código fornecido por Chris Kent na postagem vinculada para tentar resolver meu problema.

O que estou tentando realizar aqui é extrair um intervalo específico de dados de várias pastas de trabalho e colá-los em um usando o VBA no Excel 2010. Eventualmente, adicionarei uma página de resumo da soma de cada conjunto de dados. Por enquanto, meu principal problema é obter as informações de várias pastas de trabalho para copiar com êxito.

Cada intervalo é o mesmo em cada pasta de trabalho.

Eu não preciso de cabeçalhos para serem puxados.

Eu só preciso de 1 folha de dados.

No código que manipulei para melhor atender às minhas necessidades abaixo, estou com os seguintes problemas:

1. Os dados dos dois primeiros arquivos (datas 11-23-15 e 11-24-15) não estão parados. Tenho a sensação de que isso tem a ver com a parte não editada do código que ainda estou prestes a tocar sobre a remoção de colunas / linhas com 0 mostradas abaixo.

   Private Function GetTrueEnd(ws As Worksheet) As Range
       Dim lastRow As Long
       Dim lastCol As Long
       Dim r As Long
       Dim c As Long
   
       On Error Resume Next
       lastCol = ws.UsedRange.Find("*", , , xlPart, xlByColumns, xlPrevious).Column
       lastRow = ws.UsedRange.Find("*", , , xlPart, xlByRows, xlPrevious).Row
       On Error GoTo 0
   
       If lastCol <> 0 And lastRow <> 0 Then
   
           ' look back through the last rows of the table, looking for a non-zero value
           For r = lastRow To 1 Step -1
               For c = 1 To lastCol
                   If ws.Cells(r, c).Text <> "" Then
                       If ws.Cells(r, c).Text <> 0 Then
                           Set GetTrueEnd = ws.Cells(r, lastCol)
                           Exit Function
                       End If
                   End If
               Next c
           Next r
       End If
   
       Set GetTrueEnd = ws.Cells(1, 1)
   End Function
   

2. A data do primeiro arquivo (como Nome do arquivo) é listada na Coluna B e a data do segundo arquivo é listada na Coluna C quando eles devem ser listados na Coluna E. Isso pode fazer parte do mesma suposição que tenho em # 1.

3. Os dados de 11-25-15 e 11-26-15 têm um #REF! erro. Espero que, se descobrir como extrair somente valores e não fórmulas, isso corrija esse erro. No entanto, isso não acontece em outras datas, por isso não tenho certeza se esse é o problema subjacente. O único lugar que conheço para tentar usar os códigos '.Value' ou '.Pastespecial' está no seguinte, mas ainda não consegui fazê-lo funcionar:

   If mainLastEnd(i).Row > 1 Then
   ' There is data in the sheet
   
   ' Copy new data (skip headings)
           externWorkbook.Sheets(i).Range("A19:E23").Copy ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row + 2, 1)
   

Sealguémpudermeajudararesolverosproblemasacima,agradeceriamuito.

Aquiestátodoocódigo:

OptionExplicitConstNUMBER_OF_SHEETS=1PublicSubGiantMerge()DimexternWorkbookFilepathAsVariantDimexternWorkbookAsWorkbookDimiAsLongDimmainLastEnd(1ToNUMBER_OF_SHEETS)AsRangeDimmainCurEndAsRangeApplication.ScreenUpdating=False'Initialise'CorrectnumberofsheetsApplication.DisplayAlerts=FalseIfThisWorkbook.Sheets.Count<NUMBER_OF_SHEETSThenThisWorkbook.Sheets.AddCount:=NUMBER_OF_SHEETS-ThisWorkbook.Sheets.CountElseIfThisWorkbook.Sheets.Count>NUMBER_OF_SHEETSThenFori=ThisWorkbook.Sheets.CountToNUMBER_OF_SHEETS+1Step-1ThisWorkbook.Sheets(i).DeleteNextiEndIfApplication.DisplayAlerts=TrueFori=1ToNUMBER_OF_SHEETSSetmainLastEnd(i)=GetTrueEnd(ThisWorkbook.Sheets(i))Nexti'LoadthedataForEachexternWorkbookFilepathInGetWorkbooks()SetexternWorkbook=Application.Workbooks.Open(externWorkbookFilepath,,True)Fori=1ToNUMBER_OF_SHEETSIfmainLastEnd(i).Row>1Then'Thereisdatainthesheet'Copynewdata(skipheadings)externWorkbook.Sheets(i).Range("A19:E23").Copy ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row + 2, 1)

                ' Find the end column and row
                Set mainCurEnd = GetTrueEnd(ThisWorkbook.Sheets(i))
            Else
                ' No data in sheet yet (prob very first run)

                ' Get correct sheet name from first file we check
                ThisWorkbook.Sheets(i).Name = externWorkbook.Sheets(i).Name


                ' Find the end column and row
                Set mainCurEnd = GetTrueEnd(ThisWorkbook.Sheets(i)).Offset(, 1)


            End If

            ' Add file name into extra column
            ThisWorkbook.Sheets(i).Range(ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row + 1, mainCurEnd.Column), mainCurEnd).Value = externWorkbook.Name

            Set mainLastEnd(i) = mainCurEnd
        Next i

        externWorkbook.Close
    Next externWorkbookFilepath

    Application.ScreenUpdating = True
    End Sub

    ' Returns a collection of file paths, or an empty collection if the user selects cancel
    Private Function GetWorkbooks() As Collection
    Dim fileNames As Variant
    Dim xlFile As Variant

    Set GetWorkbooks = New Collection

    fileNames = Application.GetOpenFilename(Title:="Please choose the files to merge", _
                                               FileFilter:="Excel Files, *.xlsm;*.xlsx", _
                                               MultiSelect:=True)
    If TypeName(fileNames) = "Variant()" Then
        For Each xlFile In fileNames
            GetWorkbooks.Add xlFile
        Next xlFile
    End If
    End Function

    ' Finds the true end of the table (excluding unused columns/rows and rows filled with 0's)
    Private Function GetTrueEnd(ws As Worksheet) As Range
    Dim lastRow As Long
    Dim lastCol As Long
    Dim r As Long
    Dim c As Long

    On Error Resume Next
    lastCol = ws.UsedRange.Find("*", , , xlPart, xlByColumns, xlPrevious).Column
    lastRow = ws.UsedRange.Find("*", , , xlPart, xlByRows, xlPrevious).Row
    On Error GoTo 0

    If lastCol <> 0 And lastRow <> 0 Then

        ' look back through the last rows of the table, looking for a non-zero value
        For r = lastRow To 1 Step -1
            For c = 1 To lastCol
                If ws.Cells(r, c).Text <> "" Then
                    If ws.Cells(r, c).Text <> 0 Then
                        Set GetTrueEnd = ws.Cells(r, lastCol)
                        Exit Function
                    End If
                End If
            Next c
        Next r
    End If

    Set GetTrueEnd = ws.Cells(1, 1)
    End Function

    

Answer 1

Eu encontrei um código diferente que satisfez minhas necessidades. Eu terei algumas coisas para ajustar, como adicionar uma função de classificação.

Esse código pegou todos os arquivos que eu gostaria de abrir, copiou a seleção e colou em uma nova planilha, combinando todos os dados para um de várias planilhas.

Ele abre os dados em uma nova planilha fora da que estou executando o código, mas funciona perfeitamente bem para mim. Posso escolher salvá-lo ou apenas imprimi-lo para referência.

Aqui está o link do qual eu obtive este código, modificado para atender às minhas necessidades:

Ron de Bruin: Exemplos de livros de trabalho: Mesclar dados de todas as pastas de trabalho em uma pasta

O código é o seguinte:

Option Explicit


Sub Basic_Example_2()
    Dim MyPath As String
    Dim SourceRcount As Long, Fnum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
    Dim SaveDriveDir As String
    Dim FName As Variant




FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
                                    MultiSelect:=True)
If IsArray(FName) Then

    'Add a new workbook with one sheet
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    rnum = 1


    'Loop through all files in the array(myFiles)
    For Fnum = LBound(FName) To UBound(FName)
        Set mybook = Nothing
        On Error Resume Next
        Set mybook = Workbooks.Open(FName(Fnum))
        On Error GoTo 0

        If Not mybook Is Nothing Then

            On Error Resume Next
            With mybook.Worksheets(1)
                Set sourceRange = .Range("A19:E23")
            End With

            If Err.Number > 0 Then
                Err.Clear
                Set sourceRange = Nothing
            Else
                'if SourceRange use all columns then skip this file
                If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                    Set sourceRange = Nothing
                End If
            End If
            On Error GoTo 0

            If Not sourceRange Is Nothing Then

                SourceRcount = sourceRange.Rows.Count

                If rnum + SourceRcount >= BaseWks.Rows.Count Then
                    MsgBox "Sorry there are not enough rows in the sheet"
                    BaseWks.Columns.AutoFit
                    mybook.Close savechanges:=False
                    GoTo ExitTheSub
                Else

                    'Copy the file name in column A
                    With sourceRange
                        BaseWks.Cells(rnum, "A"). _
                                Resize(.Rows.Count).Value = FName(Fnum)
                    End With

                    'Set the destrange
                    Set destrange = BaseWks.Range("B" & rnum)

                    'we copy the values from the sourceRange to the destrange
                    With sourceRange
                        Set destrange = destrange. _
                                        Resize(.Rows.Count, .Columns.Count)
                    End With
                    destrange.Value = sourceRange.Value

                    rnum = rnum + SourceRcount
                End If
            End If
            mybook.Close savechanges:=False
        End If

    Next Fnum
    BaseWks.Columns.AutoFit
End If

ExitTheSub:

End Sub