一个和尚挑水喝，两个和尚抬水喝，三个和尚没水喝.....
excel多表数据集合
上一篇 /
下一篇 2011-10-08 14:52:34
/ 个人分类：有用东东
Sub hz_1() '对excel 2007版不适用
Application.ScreenUpdating = False '关闭屏幕刷新
With Application.FileSearch
.LookIn = ThisWorkbook.Path & "\hqmb" '在这里设置所在的文件夹位置
.FileType = msoFileTypeExcelWorkbooks '设置文件类型
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
xh = ThisWorkbook.Worksheets(1).[b65536].End(xlUp).Row + 1
Workbooks.Open Filename:=.FoundFiles(i) '打开
工作簿文件
h = ActiveWorkbook.Worksheets(1).[a65536].End(xlUp).Row
ActiveWorkbook.Worksheets(1).[a1].Resize(h, 2).Copy ThisWorkbook.Worksheets(1).Cells(xh, 1)
ActiveWorkbook.Close savechanges:=False '关闭工作簿文件
Next i
Application.ScreenUpdating = True '打开屏幕刷新
MsgBox "数据汇总完成"
Else
MsgBox "没有找到任何工作簿文件"
End If
End With
End Sub
第二种方法：
Sub hz_2()
Dim MyName$, arr() As String, m&, i&
On Error Resume Next
MyName = Dir(ThisWorkbook.Path & "\hqmb\*.xls")
Do While MyName <> ""
m = m + 1
ReDim Preserve arr(1 To m)
arr(m) = MyName
MyName = Dir
Loop
Application.ScreenUpdating = False '关闭屏幕刷新
If m > 0 Then
For i = 1 To m
xh = ThisWorkbook.Worksheets(1).[b65536].End(xlUp).Row + 1
Workbooks.Open (ThisWorkbook.Path & "\hqmb\" & arr(i))
h = ActiveWorkbook.Worksheets(1).[a65536].End(xlUp).Row
ActiveWorkbook.Worksheets(1).[a1].Resize(h, 2).Copy ThisWorkbook.Worksheets(1).Cells(xh, 1)
ActiveWorkbook.Close
Next i
Application.ScreenUpdating = True '打开屏幕刷新
MsgBox "数据汇总完成"
Else
MsgBox "没有找到任何工作簿文件"
End If
End Sub
收藏
举报
TAG:
