我有多个共享相同结构的工作簿。
例如：
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
....
答案 0 :(得分：0)
此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
答案 1 :(得分：0)
调整常量部分中的值以适合您的需求。
'*******************************************************************************
' 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
'*******************************************************************************
对于大量的行，如果要通过实现联合范围来复制整个行，则此代码可能会更快。