[已解决]VBA提取信息

as0810114 · 发表于 2013-6-7 20:42

遍历指定文件夹下的所有工作簿，将各工作簿中命名为“提成表”的信息复制粘贴到“汇总”表中，需求详见附件。

最佳答案

开心妙妙

2013-6-7 22:15

Sub 汇总()
Application.ScreenUpdating = False
Dim lj As String
Dim dirname As String
Dim nm As String
Dim i As Integer
lj = ActiveWorkbook.Path '激活工作簿路径
nm = ActiveWorkbook.Name '激活工作簿名称
dirname = Dir(lj & "\*.xls*") '用DIR取得工作表名
Cells.Clear '删除数据
Do While dirname <> "" '工作簿名<>空，就循环
If dirname <> nm Then '如果工作表簿<>激活工作簿名
Workbooks.Open Filename:=lj & "" & dirname '打开DIR找到的工作簿
i = Workbooks(dirname).Sheets("提成表").Range("A65536").End(xlUp).Row
Sheets("提成表").Activate
Workbooks(nm).Activate
Workbooks(dirname).Sheets("提成表").Range("A1:W" & i).Copy Range("A65536").End(xlUp).Offset(2, 0)
Workbooks(dirname).Close False '关闭工作簿不保存修改
End If
dirname = Dir
Loop
Application.ScreenUpdating = True
End Sub

复制代码

hwc2ycy · 发表于 2013-6-7 20:49

这个应该不难啊。亲。

开心妙妙 · 发表于 2013-6-7 22:02

本帖最后由开心妙妙于 2013-6-7 22:18 编辑

汇总.zip (95.94 KB, 下载次数: 19)

开心妙妙 · 发表于 2013-6-7 22:15

Sub 汇总()
Application.ScreenUpdating = False
Dim lj As String
Dim dirname As String
Dim nm As String
Dim i As Integer
lj = ActiveWorkbook.Path '激活工作簿路径
nm = ActiveWorkbook.Name '激活工作簿名称
dirname = Dir(lj & "\*.xls*") '用DIR取得工作表名
Cells.Clear '删除数据
Do While dirname <> "" '工作簿名<>空，就循环
If dirname <> nm Then '如果工作表簿<>激活工作簿名
Workbooks.Open Filename:=lj & "" & dirname '打开DIR找到的工作簿
i = Workbooks(dirname).Sheets("提成表").Range("A65536").End(xlUp).Row
Sheets("提成表").Activate
Workbooks(nm).Activate
Workbooks(dirname).Sheets("提成表").Range("A1:W" & i).Copy Range("A65536").End(xlUp).Offset(2, 0)
Workbooks(dirname).Close False '关闭工作簿不保存修改
End If
dirname = Dir
Loop
Application.ScreenUpdating = True
End Sub

复制代码

		自动登录	找回密码
密码			注册