Sub Copy_Data()
Dim wb As Workbook, rng As Range, sht As Worksheet
Dim sht_Name, theDate
sht_Name = "Sheet1" '假设所有报表文件中的数据都在 Sheet1
Set sht = ActiveSheet '保存当前工作表对象
fn = Dir(ThisWorkbook.Path & "\报表-*.xls", vbReadOnly) '打开第一个报表文件
Do While fn <> "" '开始循环
Set wb = Workbooks.Open(fn) '以只读模式打开报表文件
'取得报表文件中的日期
字符串 theDate = Mid(fn, InStr(fn, "\报表-") + 4, Len(fn) - InStr(fn, "\报表-") - 7)
'将报表文件中的数据复制到当前工作表
With wb.Worksheets(sht_Name)
.Range(.Range("A2"), .Range("A1").End(xlToRight).End(xlDown)).Copy _
Destination:=sht.Range("A65536").End(xlUp).Offset(1, 1)
End With
wb.Close (False) '关闭报表文件,不保存
sht.Activate '激活当前工作表
Range(Range("A65536").End(xlUp).Offset(1, 0), Range("B65536").End(xlUp).Offset(0, -1)) = DateValue(Format(theDate, "0000-00-00")) '在A列填充报表文件的日期信息
fn = Dir
Loop '循环下一个报表文件
End Sub
追问
我确定把这个工作表和报表是放在同一个文件夹的,运行宏的时候怎么出现这种错误
追答请问,报表文件是 2007/2010 版的吗?那么后缀应该是 xlsx(我看提问中写的是 xls),那么代码要略作修改:
Sub Copy_Data()
Dim wb As Workbook, rng As Range, sht As Worksheet
Dim sht_Name, theDate
sht_Name = "Sheet1"
Set sht = ActiveSheet
fn = Dir(ThisWorkbook.Path & "\报表-*.xlsx", vbReadOnly)
Do While fn <> ""
Set wb = Workbooks.Open(fn)
theDate = Mid(fn, InStr(fn, "\报表-") + 4, Len(fn) - InStr(fn, "\报表-") - 8)
With wb.Worksheets(sht_Name)
.Range(.Range("A2"), .Range("A1").End(xlToRight).End(xlDown)).Copy _
Destination:=sht.Range("A65536").End(xlUp).Offset(1, 1)
End With
wb.Close (False)
sht.Activate
Range(Range("A65536").End(xlUp).Offset(1, 0), Range("B65536").End(xlUp).Offset(0, -1)) = DateValue(Format(theDate, "0000-00-00"))
fn = Dir
Loop
End Sub
上面的代码请粘贴在 worksheet 的代码窗口,然后将这个文件与报表文件保存在同一个文件夹中。
fn = Dir(ThisWorkbook.Path & "\报表-*.xlsx", vbReadOnly) 这句代码保证了能够打开同一文件夹中的所有报表文件。
追问我是office2013,我开始就是修改了xls为xlsx,但还是不能打开,我再试试
追答呃!2013,太先进了,俺木有这个环境,T_T