Как собрать данные из всех строк из разных книг Excel и отсортировать их?

Question

У меня есть несколько книг, которые имеют одинаковую структуру.

Например:

Book1.xls

      A     B
1   Item1 16:05
2   Item2 09:05
....

Book2.xls

      A     B
1   Item3 07:35
2   Item4 22:15
....

Эти рабочие книги обновляются каждый день и могут содержать любое количество строк с данными.

Мне нужно извлечь все строки из всех книг и отсортировать их по времени.

Например:

AllData.xls

      A     B
1   Item3 07:35
2   Item2 09:05
3   Item1 16:05
4   Item4 22:15
....

Answer 1

Сортировка из рабочих книг

Настройте значения в разделе констант в соответствии со своими потребностями.

Код

'*******************************************************************************
' Purpose:    Copies a range from all workbooks in a folder to this workbook
'             and sorts the resulting range by a specified column.
'*******************************************************************************
Sub FromWorkbooksSort()

    ' Source File Folder Path
    Const cStrFolder As String = _
        "C:\"
    Const cStrExt As String = "*.xls*"       ' Source File Pattern
    Const cVntSName As Variant = 1           ' Source Worksheet Name/Index
    Const cIntSFirstRow As Integer = 1       ' Source First Row Number
    Const cVntSFirstColumn As Variant = "A"  ' Source First Column Letter/Number

    Const cIntColumns As Integer = 2         ' Source/Target Number of Columns

    ' Target Headers List
    Const cStrHeaders As String = "Item,Time"
    Const cVntTName As Variant = "Sheet1"    ' Target Worksheet Name/Index
    Const cIntTFirstRow As Integer = 1       ' Target First Row Number
    Const cVntTFirstColumn As Variant = "A"  ' Target First Column Letter/Number
    Const cIntTSortColumn As Integer = 2     ' Target Sort Column

    Dim objSWorkbook As Workbook    ' Source Workbook
    Dim strSFileName As String      ' Source File Name
    Dim lngSLastRow As Long         ' Source Last Row

    Dim objTWorksheet As Worksheet  ' Target Worksheet
    Dim vntTHeaders As Variant      ' Target Headers Array
    Dim lngTLastRow As Long         ' Target Last Row
    Dim i As Integer                ' Target Headers Row Counter

    ' Speed up.
    With Application
      .ScreenUpdating = False
      .Calculation = xlCalculationManual
      .DisplayAlerts = False
    End With

    ' Minor Error Handling
    On Error GoTo ErrorHandler

    ' Clear and write headers to Target Worksheet.
    Set objTWorksheet = ThisWorkbook.Worksheets(cVntTName)
    objTWorksheet.Cells.Clear
    vntTHeaders = Split(cStrHeaders, ",")
    For i = 0 To UBound(vntTHeaders)
        objTWorksheet.Cells(cIntTFirstRow, cVntTFirstColumn).Offset(0, i) _
                = vntTHeaders(i)
    Next

    ' Loop through all workbooks in folder.
    strSFileName = Dir(cStrFolder & "\" & cStrExt)
    Do While Len(strSFileName) > 0

        Set objSWorkbook = Workbooks.Open(cStrFolder & "\" & strSFileName)

        With objSWorkbook.Worksheets(cVntSName)
            ' Calculate current Source Last Row in Source First Column.
            lngSLastRow = .Cells(.Rows.Count, cVntSFirstColumn).End(xlUp).Row
            ' Check if Source First Column is empty.
            If lngSLastRow = 1 And IsEmpty(.Cells(1, 1)) Then
              Else
                ' Calculate current Target Last Row in Target First Column.
                With objTWorksheet.Cells(.Rows.Count, cVntTFirstColumn)
                    lngTLastRow = .End(xlUp).Row
                End With
                ' Copy from Source Worksheet to Target Worksheet.
                .Cells(cIntSFirstRow, cVntSFirstColumn) _
                        .Resize(lngSLastRow, cIntColumns).Copy _
                        objTWorksheet.Cells(lngTLastRow + 1, cVntTFirstColumn)
            End If
        End With

        objSWorkbook.Close False ' Close current workbook without saving.

        ' Next file (workbook).
        strSFileName = Dir

    Loop

    With objTWorksheet
        ' Calculate current Target Last Row in Target First Column.
        lngTLastRow = .Cells(.Rows.Count, cVntTFirstColumn).End(xlUp).Row
        ' Sort Target Range.
        With .Cells(cIntTFirstRow, cVntTFirstColumn).Resize(lngTLastRow _
                - cIntTFirstRow + 1, cIntColumns)
            .Sort Key1:=.Parent.Cells(cIntTFirstRow, .Parent.Cells(1, _
                    cVntTFirstColumn).Column + cIntTSortColumn - 1), _
                    Header:=xlYes
        End With
    End With

ProcedureExit:

    ' Clean up.
    Set objSWorkbook = Nothing
    Set objTWorksheet = Nothing

    ' Speed down.
    With Application
      .DisplayAlerts = True
      .Calculation = xlCalculationAutomatic
      .ScreenUpdating = True
    End With

Exit Sub

ErrorHandler:
    MsgBox "Error: " & Err.Number & vbCr & Err.Description
    On Error GoTo 0
    GoTo ProcedureExit

End Sub
'*******************************************************************************

Примечания

При большем количестве строк этот код может быть быстрее, если копировать целые строки с помощью реализации Union Range.

Answer 2

Этот скрипт VBA сделает то, что вы ищете;просто измените Путь к папке, где у вас есть файлы, и заголовки, если вы не хотите, чтобы они оставались "A" и "B".

Sub RetrieveSort()

        Dim Path As String, activeWB As String, wbDest As Workbook
        Dim desSht As Worksheet, fileName As String, Wkb As Workbook, des As Range, src As Range
        Dim StartCopyingFrom As Integer

        '----------TO BE CHANGED----------
        Path = "C:\Users\AN\Desktop\Data\" 'change folder to where the data is located
        hdA = "A" 'change it to the header you want for column A, maybe Item?
        hdB = "B" 'change it to the header you want for column B, maybe Time?
        '----------TO BE CHANGED----------

        activeWB = ActiveWorkbook.Name
        StartCopyingFrom = 2 'we start copying from the second row to avoid duplicating the headers

        Set desSht = Worksheets.Add 'this is to create the sheet where all data will be merged
        fileName = Dir(Path & "\*.xls", vbNormal) 'this assumes that the files you intend to copy from are Excel files
                If Len(fileName) = 0 Then Exit Sub
                    Do Until fileName = vbNullString
                        If Not fileName = activeWB Then
                            Set Wkb = Workbooks.Open(fileName:=Path & fileName)
                            Set src = Wkb.Sheets(1).Range(Cells(StartCopyingFrom, 1), _
                            Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
                            Set des = desSht.Range("A" & desSht.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
                            src.Copy des 'copying the data
                            Wkb.Close False 'we close the file after retrieving the data and close it without saving
                End If

                fileName = Dir()
                    Loop

Range("A1").Value = hdA
Range("B1").Value = hdB

lastRow = Range("A" & Rows.Count).End(xlUp).Row 'this will get the total number of rows, and it changes depending on your data

 Range("A1:B" & lastRow).Select        'sorting by time
                            Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:= _
                                False, Orientation:=xlTopToBottom

End Sub