|
我改了一下以前的程序,程序比较乱,符合你的要求了。你看看。。- Sub 汇总()
- Dim Arr(1 To 1000, 1 To 2), i%, j%, drow%, Erow%, eerow%
- Dim filename As String, wb As Workbook, sht As Worksheet, shtname As String
- Dim fn As String, d, k, str As String
- ' Set d = CreateObject("Scripting.Dictionary")
- '关闭屏幕闪烁和警告框
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- 'On Error GoTo VeryEnd
- ' ThisWorkbook.Worksheets("sheet1").Range("a2:y550000").ClearContents '清除汇总表中原来的数据
- i = 1
- filename = Dir(ThisWorkbook.Path & "\*.xls")
- Do While filename <> ""
- If filename <> ThisWorkbook.Name Then '判断文件是否是本工作簿
- fn = ThisWorkbook.Path & "" & filename
- Set wb = GetObject(fn) '将fn代表的工作簿对象赋给变量
- Set sht = wb.Sheets(1)
- ' drow = sht.[a65536].End(3).Row
- ' MsgBox drow
- Arr(i, 1) = sht.Name
- Arr(i, 2) = sht.[k45].Value
- i = i + 1
- wb.Close False
- End If
- filename = Dir
- Loop
- VeryEnd:
- ThisWorkbook.Worksheets("sheet1").Range("a2").Resize(UBound(Arr, 1), 2) = Arr
- MsgBox "汇总完成,请查看"
- Application.ScreenUpdating = True
- Application.DisplayAlerts = True
- End Sub
复制代码 |
|