求提取数据的VBA

briancai20 · 发表于 2016-1-15 17:50

各位大神，

我需要提取一个文件夹中各个子文件夹中的所有工作簿中所有工作表的O1到S1的所有数据到当前汇总表的sheet1中。请大师帮忙提供代码，我自己写的都不成功。

要求，1. 文件夹中有n个子文件夹
2. 子文件夹中有n个工作簿，工作簿中有n个工作表。我需要历遍每个工作表，然后提取O1到S1的数据到当前汇总表中。

bajifeng · 发表于 2016-1-15 18:23

所有工作表的O1到S1的所有数据到当前汇总表的sheet1中
放在sheet1中的哪里？

bajifeng · 发表于 2016-1-15 18:39

Sub BJF() 'by: bajifeng
Dim brr(), crr(), Rng As Range
Set sho = ThisWorkbook.ActiveSheet
fl = ListFile(ThisWorkbook.Path, True, "*.xls?") 'ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改
'Debug.Print UBound(fl)
Application.ScreenUpdating = False '关闭屏幕刷新，提高速度
For l = 0 To UBound(fl)
If fl(l) <> "" Then
If InStr(fl(l), "汇总") = 0 Then
On Error GoTo 100
'Debug.Print fl(l)
Workbooks.Open fl(l)
On Error GoTo 0
'+++++++++++++++++++++++++++++++++++++++
For Each sht In Worksheets
n = n + 1
arr = sht.[o1:s1]
ReDim Preserve brr(1 To 5, 1 To n)
'Debug.Print TypeName(ds)
For i = 1 To n
brr(1, n) = arr(1, 1)
brr(2, n) = arr(1, 2)
brr(3, n) = arr(1, 3)
brr(4, n) = arr(1, 4)
brr(5, n) = arr(1, 5)
Next
Next
'+++++++++++++++++++++++++++++++++++++++
If fl(l) <> ThisWorkbook.Path Then ActiveWorkbook.Close True
End If
End If
100:
Next
[a2:f999] = ""
[a2].Resize(n, 5) = Application.Transpose(brr)
Columns("a:f").AutoFit
Application.ScreenUpdating = True
MsgBox "处理完毕！"
End Sub
Private Function ListFile(MuLu As String, Zi As Boolean, Optional LeiXing As String = "")
Dim MyFile As String, ms As String
Dim arr, brr, x
Dim i As Integer
Set d = CreateObject("Scripting.Dictionary")
If Left(MuLu, 1) <> "" Then MuLu = MuLu & ""
d.Add MuLu, ""
i = 0
Do While i < d.Count
brr = d.keys
MyFile = Dir(brr(i), vbDirectory)
Do While MyFile <> ""
If MyFile <> "." And MyFile <> ".." Then
If (GetAttr(brr(i) & MyFile) And vbDirectory) = vbDirectory Then d.Add (brr(i) & MyFile & ""), ""
End If
MyFile = Dir
Loop
If Zi = False Then Exit Do
i = i + 1
Loop
If LeiXing = "" Then
ListFile = Application.Transpose(d.keys)
Else
For Each x In d.keys
MyFile = Dir(x & LeiXing)
Do While MyFile <> ""
ms = ms & x & MyFile & ","
MyFile = Dir
Loop
If Zi = False Then Exit For
Next
If ms = "" Then ms = "没有符合要求的文件,"
'ListFile = Application.Transpose(Split(ms, ",")) '下标从1开始
ListFile = Split(ms, ",") '下标从0开始
End If
End Function

复制代码

bajifeng · 发表于 2016-1-15 18:39

本帖最后由 bajifeng 于 2016-1-15 21:35 编辑

>>>>>>>>
前面传错附件了，已经更新附件。

briancai20 · 发表于 2016-1-15 20:17

bajifeng 发表于 2016-1-15 18:39
》》》》》》》》》》》》

什么也没有呀

bajifeng · 发表于 2016-1-15 20:32

.....
怎么会什么都没有呢？
你不是要提取 01：s1的数据吗？
看下面的动画，有数据的。

briancai20 · 发表于 2016-1-15 21:19

bajifeng 发表于 2016-1-15 20:32
.....
怎么会什么都没有呢？
你不是要提取 01：s1的数据吗？

我下载后没有按钮，能否把代码贴给我。谢谢！

bajifeng · 发表于 2016-1-15 21:35

briancai20 发表于 2016-1-15 21:19
我下载后没有按钮，能否把代码贴给我。谢谢！

不好意思，
前面传错附件了，已经更新附件。
附件在4楼

chenbiao2012 · 发表于 2016-1-15 21:35

Sub test()
Application.ScreenUpdating = False
Dim brr(1 To 1000, 1 To 4)
Set fso = CreateObject("Scripting.FileSystemObject")
For Each fs In fso.getfolder(ThisWorkbook.Path & "").subfolders
f = Dir(fs & "\*.xls*")
Do While f <> ""
If f <> ThisWorkbook.Name Then
With GetObject(fs & "" & f)
For Each sh In .Sheets
With sh
n = n + 1
arr = .Range("o1:s1")
End With
For i = 1 To 4
brr(n, i) = arr(1, i)
Next
Next
.Close 0
End With
End If
f = Dir
Loop
Set fs = Nothing
Next
With Sheets("sheet1")
.UsedRange.Offset(1).ClearContents
.[a2].Resize(n, 4) = brr
End With
Application.ScreenUpdating = True
End Sub

复制代码

briancai20 · 发表于 2016-1-17 10:16

chenbiao2012 发表于 2016-1-15 21:35

非常好，已经搞定，谢谢！

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

[求助] 求提取数据的VBA

评分

评分