|
简单处理了一下。添加了一点代码。把下面的代码替换原代码试试 Sub GET_hjsong_MX() '汇总程序，打开所有的工作簿，依次取数
Dim files
Dim a&, b&, m&, i%
Dim sht As Worksheet, Chjs As Worksheet
Dim wb As Workbook Application.ScreenUpdating = False '关闭屏幕更新，防止闪屏、加快代码运行 files = Application.GetOpenFilename("所有文件(*.xls),*.xls", , , , True) '选取一个范围，可以选多个excel文件
If Not IsArray(files) Then '如果按取消，没有选择的时候，删除新增的表，并退出程序
MsgBox "没有选定工作薄！～"
Exit Sub
End If SHtAdd '每次运行之前都重新增加一个工作表“hjsong”
Set Chjs = ThisWorkbook.Sheets("hjsong") '给汇总表赋值 m = 2
For i = LBound(files) To UBound(files) '对于getopenfilename得到的是一个数组，从数组的第一个到，最后一个循环
Set wb = Workbooks.Open(files(i)) '依次打开
N = Application.Substitute(wb.Name, ".xls", "") '取工作簿的名称
For Each sht In wb.Sheets '在新打开的工作簿的工作表里循环
If sht.Name = "2006年7月" Then '先判断表名，然后判断里面是否有数据
a = GETrow(sht) 'a为最大行，b为最大列
b = GETcol(sht) If a > 1 And b > 1 Then '如果有数据的话
'如果没有对表名的控制的话，会汇总所有有数据的表，其实这里可以自定义一个函数，根据格式判断哪些工作表需要汇总 If sht.AutoFilterMode = True Then sht.AutoFilterMode = False '如果有自动筛选就取消自动筛选 If i = LBound(files) Then '第一个工作表时，复制标题（第一行内容）
sht.Range(sht.Cells(1, 1), sht.Cells(1, b)).Copy Chjs.Cells(1, 2)
For t = 1 To b '复制列宽
Chjs.Cells(1, t + 1).ColumnWidth = sht.Cells(1, t).ColumnWidth
Next t
End If
sht.Range(sht.Cells(2, 1), sht.Cells(a, b)).Copy Chjs.Cells(m, 2) '开始复制数据到B列最后的一行里.
Chjs.Cells.Copy
Chjs.Cells.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = xlCopy
Chjs.Cells(m, 1) = N 'A列为工作簿名称
m = GETrow(Chjs) + 1 '重新计算hjsong表里的最后一非空行 End If
End If
Next sht
wb.Close False '不保存，关闭打开的表
Next i Application.ScreenUpdating = True '重新打开屏幕更新 End Sub | 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2006-9-20 12:11
楼主