提取多个文件夹下多个工作簿中指定工作表的数据到新工作簿中

liushilin

谢谢AVEL 老师的指导，加入上述条件后测试目前没问题，我还有个简单的表格也想用VBA实现，麻烦老师抽个时间帮忙写个代码，本人实在是个菜鸟，辛苦你了。

AVEL

1. Sub l()
   
2.     Dim arr As Variant
   
3.     Dim n As Integer, i As Integer, r As Integer
   
4.     Dim brr(1 To 10000, 1 To 5)
   
5.     arr = Sheet13.Range("a6:e" & Sheet13.[a65536].End(3).Row).Value
   
6.     n = Sheet1.[a65536].End(3)(2).Row - 1
   
7.     For i = 1 To UBound(arr)
   
8.         If Len(arr(i, 5)) Then
   
9.             r = r + 1
   
10.             brr(r, 1) = n
    
11.             brr(r, 2) = arr(i, 3)
    
12.             brr(r, 4) = arr(i, 4)
    
13.             brr(r, 5) = arr(i, 5)
    
14.             n = n + 1
    
15.         End If
    
16.     Next
    
17.     Sheet1.[a65536].End(3)(2).Resize(r, 5).Value = brr
    
18. End Sub

复制代码

AVEL

EH(AVEL)-统计表 12-07-29 16-25.rar (15.14 KB, 下载次数: 187)

2012-7-29 16:25 上传

点击文件名下载附件

liushilin

AVEL 发表于 2012-7-29 16:25

1. Sub l()
   
2.     Dim arr As Variant
   
3.     Dim n As Integer, i As Integer, r As Integer
   
4.     Dim brr(1 To 10000, 1 To 5)
   
5.     arr = Sheet13.Range("a6:e" & Sheet13.[a65536].End(3).Row).Value
   
6.     n = Sheet1.[a65536].End(3)(2).Row - 1
   
7.     For i = 1 To UBound(arr)
   
8.         If arr(i, 5) > 0 Then
   
9.             r = r + 1
   
10.             brr(r, 1) = n
    
11.             brr(r, 2) = arr(i, 3)
    
12.             brr(r, 4) = arr(i, 4)
    
13.             brr(r, 5) = arr(i, 5)
    
14.             n = n + 1
    
15.         End If
    
16.     Next
    
17.     Sheet1.[a65536].End(3)(2).Resize(r, 5).Value = brr
    
18. End Sub
    

复制代码

老师，因为我需要的是E列大于0的进行复制，但我E列单元格内有可能是0值或负值，按你的代码，如是0值也复制过去了，我试着改了一下你的代码，是可能将大于0值的复制过去了，但问题有来了，如果E列没有大于0的运行就出问题了，你能帮忙看看，改改吗，感谢！

AVEL

最后一句改一下好了
    If brr(1, 1) <> "" Then Sheet1.[a65536].End(3)(2).Resize(r, 5).Value = brr

jhzghua

记一下，有用。

liushilin

AVEL 发表于 2012-7-24 20:25
新附件 测试看看、

又要麻烦老师了，我照着你写的上述代码修改了一下用到我现在的汇总表里，基本可能实现新的汇总要求，但是有个小问题，现在的汇总表与之前的汇总表有点变动，就是单个文件的文件名的位置变动了，自己想破脑袋都没想出来怎么改，还请老师能抽空帮忙教一下，感谢！详见附件。

AVEL

liushilin 发表于 2012-10-17 23:35
又要麻烦老师了，我照着你写的上述代码修改了一下用到我现在的汇总表里，基本可能实现新的汇总要求，但是 ...

1. Sub 表三甲线路汇总()
   
2.     Dim sh As Worksheet, Myname$
   
3.     Dim brr(1 To 60000, 1 To 7), crr As Variant
   
4.     Dim n As Integer, i As Integer, j As Integer, wn As String, k As Integer
   
5.     Set sh = ActiveSheet
   
6.     fld ThisWorkbook.Path
   
7.     Application.ScreenUpdating = False
   
8.     If [a6] <> "" Then Sheet1.Range("a5:g" & Sheet1.[b65536].End(3).Row).ClearContents
   
9.     For i = 1 To UBound(arr)
   
10.         Myname = Dir(arr(i))
    
11.         wn = Replace(Myname, ".xls", "")
    
12.         If InStr(wn, "结算表(线路)") Then
    
13.             If Myname <> ThisWorkbook.Name Then
    
14.                 With GetObject(arr(i))
    
15.                     If .Sheets("表三甲") Is Nothing Or .Sheets("表三甲").[b65536].End(3).Row < 7 Then GoTo nn
    
16.                     crr = .Sheets("表三甲").Range("a7:g" & .Sheets("表三甲").[b65536].End(3).Row).Value
    
17.                     n = n + 1
    
18.                     brr(n, 3) = Replace(Myname, ".xls", "")
    
19.                     For j = 1 To UBound(crr)
    
20.                         If crr(j, 1) <> "" Then
    
21.                             n = n + 1
    
22.                             brr(n, 1) = crr(j, 1)
    
23.                             For k = 2 To 7
    
24.                                 brr(n, k) = crr(j, k)
    
25.                             Next
    
26.                         End If
    
27.                     Next
    
28.                     .Close False
    
29.                 End With
    
30.             End If
    
31.         End If
    
32. nn:
    
33.     Next
    
34.     Erase arr
    
35.     l = 0
    
36.     Sheet1.[a5:g500].ClearContents
    
37.     Sheet1.[a5].Resize(n, 7).Value = brr
    
38.     Application.ScreenUpdating = True
    
39. End Sub

复制代码

fanmily

AVEL老师能否帮忙下这个汇总？
http://club.excelhome.net/forum. ... d=968869&extra=

考试加油站

AVEL 发表于 2012-7-24 20:25
新附件 测试看看、

您是这方面高手，想请给看看，工作中遇到的从多个表格中提取数据问题。
http://club.excelhome.net/thread-1050485-1-1.html