From Workbooks Sort
Adjust the values in the constants section to fit your needs.
The Code
'*******************************************************************************
' 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
'*******************************************************************************
Remarks
For a larger amount of rows, this code could be faster if entire rows were to be copied by implementing a Union Range.
与恶龙缠斗过久,自身亦成为恶龙；凝视深渊过久,深渊将回以凝视…
