[已解决]请问如何快速提取多个工作表中同一列数据

ymdhy · 发表于 2014-12-11 22:09

本帖最后由 ymdhy 于 2014-12-14 21:31 编辑

RT，现有很多个工作表，表内格式是一样的，想把所有工作表中的L列内容汇总到一个表中，请问如何快速提取？

附件举了个例子，实际中有很多张，还会不断增加，一个个复制粘贴太麻烦，请教简单方法

要求.rar (24.37 KB, 下载次数: 258)

tgydslr · 发表于 2014-12-11 22:28

上附件，说清要求才好说话
要不然说半天还是纸上谈兵
关键是这么笼统练兵也没法谈了

ymdhy · 发表于 2014-12-11 22:55

tgydslr 发表于 2014-12-11 22:28
上附件，说清要求才好说话
要不然说半天还是纸上谈兵
关键是这么笼统练兵也没法谈了

已上附件，举了个例子说明，先谢谢了！

江河行地 · 发表于 2014-12-12 08:39

是这样？

qh8600 · 发表于 2014-12-12 08:53

要求.rar (34.61 KB, 下载次数: 1520)

ymdhy · 发表于 2014-12-12 22:21

qh8600 发表于 2014-12-12 08:53
楼主试试，点击按钮就可以

vba只懂些皮毛，中间看得不太懂，能否解释下呢？

qh8600 · 发表于 2014-12-13 08:43

ymdhy 发表于 2014-12-12 22:21
vba只懂些皮毛，中间看得不太懂，能否解释下呢？

Sub demo()
Dim ar, cr, Str As String, FilePath As String, i As Integer, j As Integer, n As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
FilePath = ThisWorkbook.Path & "" '获取当前工作簿路径
Str = Dir(FilePath & "*.xls", vbNormal) '把工作簿名赋值变量
ReDim cr(1 To 60000, 1 To 18) '重新定义数组大小
Do While Str <> "" '遍历当前工作簿所在的文件夹
If Not (Str = "要求.xlsm") Then '判断工作簿名是否是要求，不是就执行下面代码
Workbooks.Open FilePath & Str '打开工作簿
With Workbooks(2)
ar = .Sheets(1).Range("A1").CurrentRegion '把工作簿第一个工作表与A1单元格相连的单元格赋值给数组
.Close savechange = True '关闭工作簿
End With
For i = 1 To UBound(ar) '循环数组
n = n + 1
For j = 1 To UBound(ar, 2)
cr(n, j) = ar(i, j) '循环把所有工作簿的第一个表的数据放入新的数组
Next
Next
End If
Str = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Range("a1").Resize(n, 2) = cr '把新数组写入当前工作簿的第一个表的a1单元格为顶点的区域
End Sub

复制代码

bagez · 发表于 2016-1-8 06:04

最后一行运行错误

addictwzy · 发表于 2017-9-27 11:21

居然只点按钮就可以了。。。好厉害啊！！

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