试试下面的代码：
Dim MyPath$, MyName$, sh As Worksheet, m&, w As WorksheetFunction, wb As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set w = WorksheetFunction
MyPath = ThisWorkbook.Path & "\采集多数据"
MyName = Dir(MyPath & "*.xls*")
[a1].CurrentRegion.Offset(1).ClearContents
Do While MyName ""
With GetObject(MyPath & MyName)
With .Sheets(1)
If w.CountA(.UsedRange.Offset(1)) Then
m = m + 1
If m = 1 Then
Set wb = Workbooks.Add(xlWBATWorksheet)
Set sh = wb.ActiveSheet
.[a1].CurrentRegion.Copy sh.[a1]
Else
.[a1].CurrentRegion.Offset(1).Copy sh.[a65536].End(xlUp).Offset(1)
End If
End If
End With
.Close False
End With
MyName = Dir
Loop
wb.SaveAs Filename:=ThisWorkbook.Path & "\采集多数据20130422.xls", FileFormat:=xlExcel8
wb.Close
Application.ScreenUpdating = True
MsgBox "ok"
End Sub
