[已解决]如何用代码提取多组数据？

dfshm

附件 提取组数据附件.rar (224.35 KB, 下载次数: 26)

2016-12-2 08:44 上传

点击文件名下载附件 谢谢！

最佳答案

月排行榜 / 总排行榜

雨吧

2016-12-2 16:54

dfshm 发表于 2016-12-2 14:37
老师你好，谢谢帮助。下载看了一下，压缩包里没有附件程序。因用手机上网，不方便复制代码，需下载附件， ...

附件解压后替换原文件夹中同名文件。


提取组数据附件.rar (21.12 KB, 下载次数: 14)

2016-12-2 16:53 上传

点击文件名下载附件

跳转到最佳答案楼层

雨吧

1. Sub YuBa()
   
2.     Dim ar, arr, brr(1 To 100, 1 To 9), i&, j&, k%, n&
   
3.     On Error GoTo Exit0
   
4.     ar = Sheet1.[a1:a3]
   
5.     ph = ThisWorkbook.Path & "\A"
   
6.     Application.ScreenUpdating = False
   
7.     For j = 1 To 49
   
8.         Set tb = Workbooks.Open(ph & j & "\1.xlsx")
   
9.         For i = 1 To UBound(ar)
   
10.             n = n + 1
    
11.             For k = 1 To 9
    
12.                 brr(n, k) = tb.Sheets(1).Cells(ar(i, 1), k)
    
13.             Next
    
14.         Next
    
15.         tb.Close False
    
16.         n = n + 1
    
17.     Next
    
18. Exit0:
    
19.     Application.ScreenUpdating = True
    
20.     Sheet2.UsedRange = ""
    
21.     Sheet2.[a1].Resize(n, 9) = brr
    
22.     MsgBox "提取结束"
    
23. End Sub

复制代码

提取组数据附件.rar (217.51 KB, 下载次数: 11)

2016-12-2 09:46 上传

点击文件名下载附件

dfshm

雨吧 发表于 2016-12-2 09:43

老师你好，谢谢帮助。下载看了一下，压缩包里没有附件程序。因用手机上网，不方便复制代码，需下载附件，麻烦一下，再谢。

雨吧

dfshm 发表于 2016-12-2 14:37
老师你好，谢谢帮助。下载看了一下，压缩包里没有附件程序。因用手机上网，不方便复制代码，需下载附件， ...

附件解压后替换原文件夹中同名文件。


提取组数据附件.rar (21.12 KB, 下载次数: 14)

2016-12-2 16:53 上传

点击文件名下载附件

雨吧

动态数组定义的有些小了，
49个文件，每个文件取3行+1空行=196行
因此楼主将动态数组定义改一下，
代码第二行改为：

Dim ar, arr, brr(1 To 200, 1 To 9), i&, j&, k%, n&