[已解决]VBA多个文件夹内多个工作簿固定单元格内数据提取

fiona_123456 · 发表于 2015-3-2 14:47

本帖最后由 fiona_123456 于 2015-3-2 14:49 编辑

各位论坛老师，想请教下如何用VBA实现在多个文件夹下多个工作簿中提取固定单元格内容
见附件，在“数据文件”文件夹下，有30多个文件夹，每个文件夹下有上百个工作簿，如何提取工作簿中
固定sheet 内（“FWXXX" sheet）固定格式内的内容（“data”列内的数据）复制到新的“数据汇总”工作表中，万分感谢!!!!

最佳答案

月排行榜 / 总排行榜

grf1973

2015-3-2 17:07

考虑格式。。。

Sub 导入()
Application.DisplayAlerts = False
Set fso = CreateObject("scripting.filesystemobject")
Set ff = fso.getfolder(ThisWorkbook.Path)
Cells.Clear: r = -10
For Each fff In ff.subfolders
n = 1: ReDim brr(1 To 11, 1 To n)
xrr = Split(fff, ""): xname = xrr(UBound(xrr))
brr(1, 1) = xname '第一列姓名
For Each f In fff.Files
Set wb = Workbooks.Open(f)
Set sht = wb.Sheets(1)
crr = sht.[d9:e18] '要导入的数据区域
ActiveWorkbook.Close False
n = n + 1
ReDim Preserve brr(1 To 11, 1 To n)
brr(1, n) = crr(1, 1) '第一行FW****
For j = 2 To UBound(brr): brr(j, n) = crr(j - 1, 2): Next
Next
r = r + 11
Cells(r, 1).Resize(11, n) = brr
Cells(r, 1).Resize(11, 1).Merge
Next
Application.DisplayAlerts = True
End Sub

复制代码

跳转到最佳答案楼层

grf1973 · 发表于 2015-3-2 16:59

Sub 导入()
Set fso = CreateObject("scripting.filesystemobject")
Set ff = fso.getfolder(ThisWorkbook.Path)
For Each fff In ff.subfolders
n = 1: ReDim brr(1 To 11, 1 To n)
xrr = Split(fff, ""): xname = xrr(UBound(xrr))
For i = 1 To UBound(brr): brr(i, 1) = xname: Next '第一列姓名
For Each f In fff.Files
Set wb = Workbooks.Open(f)
Set sht = wb.Sheets(1)
crr = sht.[d9:e18] '要导入的数据区域
ActiveWorkbook.Close False
n = n + 1
ReDim Preserve brr(1 To 11, 1 To n)
brr(1, n) = crr(1, 1) '第一行FW****
For j = 2 To UBound(brr): brr(j, n) = crr(j - 1, 2): Next
Next
r = [a65536].End(3).Row + 2
If r = 3 Then r = 1
Cells(r, 1).Resize(11, n) = brr
Next
End Sub

复制代码

grf1973 · 发表于 2015-3-2 16:59

请看附件。

grf1973 · 发表于 2015-3-2 17:07

这个最佳答案由 grf1973 给出，感谢 grf1973 的回答。

单击隐藏图章

考虑格式。。。

Sub 导入()
Application.DisplayAlerts = False
Set fso = CreateObject("scripting.filesystemobject")
Set ff = fso.getfolder(ThisWorkbook.Path)
Cells.Clear: r = -10
For Each fff In ff.subfolders
n = 1: ReDim brr(1 To 11, 1 To n)
xrr = Split(fff, ""): xname = xrr(UBound(xrr))
brr(1, 1) = xname '第一列姓名
For Each f In fff.Files
Set wb = Workbooks.Open(f)
Set sht = wb.Sheets(1)
crr = sht.[d9:e18] '要导入的数据区域
ActiveWorkbook.Close False
n = n + 1
ReDim Preserve brr(1 To 11, 1 To n)
brr(1, n) = crr(1, 1) '第一行FW****
For j = 2 To UBound(brr): brr(j, n) = crr(j - 1, 2): Next
Next
r = r + 11
Cells(r, 1).Resize(11, n) = brr
Cells(r, 1).Resize(11, 1).Merge
Next
Application.DisplayAlerts = True
End Sub

复制代码

fiona_123456 · 发表于 2015-3-5 14:33

本帖最后由 fiona_123456 于 2015-3-5 17:05 编辑

感谢grf1973的回复，想请教下如果换一种格式（纵向排列），应该怎么写？

grf1973 · 发表于 2015-3-6 09:32

新格式要简单得多

Sub 导入()
Application.ScreenUpdating = False
Set fso = CreateObject("scripting.filesystemobject")
Set ff = fso.getfolder(ThisWorkbook.Path)
Cells.ClearContents
For Each fff In ff.subfolders
xrr = Split(fff, ""): xname = xrr(UBound(xrr))
For Each f In fff.Files
Set wb = Workbooks.Open(f)
Set sht = wb.Sheets(1)
crr = sht.[d9:e18] '要导入的数据区域
ActiveWorkbook.Close False
r = [a65536].End(3).Row + 1
If r = 2 Then r = 1
Cells(r, 1).Resize(UBound(crr), 1) = xname
Cells(r, 2).Resize(UBound(crr), 2) = crr
Next
Next
Application.ScreenUpdating = True
End Sub

复制代码

Wendao63 · 发表于 2016-4-5 19:00

Xuexiliao

乐乐2006201506 · 发表于 2016-4-5 19:32

学习了。

fuxuanbo · 发表于 2016-12-8 16:46

grf1973 发表于 2015-3-6 09:32
新格式要简单得多

如果只是提取某行的数据，应如何修改，谢谢！

kilyj300 · 发表于 2017-5-17 10:53

grf1973，请问分开工作表来完成吗？

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

[已解决]VBA多个文件夹内多个工作簿固定单元格内数据提取

相关帖子